GnuCOBOL  2.0
A free COBOL compiler
typeck.c
Go to the documentation of this file.
1 /*
2  Copyright (C) 2001-2012, 2014-2016 Free Software Foundation, Inc.
3  Written by Keisuke Nishida, Roger While, Simon Sobisch
4 
5  This file is part of GnuCOBOL.
6 
7  The GnuCOBOL compiler is free software: you can redistribute it
8  and/or modify it under the terms of the GNU General Public License
9  as published by the Free Software Foundation, either version 3 of the
10  License, or (at your option) any later version.
11 
12  GnuCOBOL is distributed in the hope that it will be useful,
13  but WITHOUT ANY WARRANTY; without even the implied warranty of
14  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15  GNU General Public License for more details.
16 
17  You should have received a copy of the GNU General Public License
18  along with GnuCOBOL. If not, see <http://www.gnu.org/licenses/>.
19 */
20 
21 
22 #include "config.h"
23 
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include <stddef.h>
27 #include <string.h>
28 #include <ctype.h>
29 #include <time.h>
30 #include <limits.h>
31 #ifdef HAVE_SYS_TIME_H
32 #include <sys/time.h>
33 #endif
34 #ifdef _WIN32
35 #define WIN32_LEAN_AND_MEAN
36 #include <windows.h>
37 #endif
38 
39 #ifdef HAVE_LOCALE_H
40 #include <locale.h>
41 #endif
42 
43 #include "cobc.h"
44 #include "tree.h"
45 
46 struct system_table {
47  const char *const syst_name;
48  const int syst_params;
49 };
50 
51 struct optim_table {
52  const char *const optim_name;
53  const enum cb_optim optim_val;
54 };
55 
56 struct expr_node {
57  /* The token of this node.
58  * 'x' - values (cb_tree)
59  * '+', '-', '*', '/', '^' - arithmetic operators
60  * '=', '~', '<', '>', '[', ']' - relational operators
61  * '!', '&', '|' - logical operators
62  * '(', ')' - parentheses
63  */
64  int token;
65  /* The value itself if this node is a value */
66  cb_tree value;
67 };
68 
69 #define START_STACK_SIZE 32
70 #define TOKEN(offset) (expr_stack[expr_index + offset].token)
71 #define VALUE(offset) (expr_stack[expr_index + offset].value)
72 
73 #define dpush(x) CB_ADD_TO_CHAIN (x, decimal_stack)
74 
75 #define cb_emit(x) \
76  current_statement->body = cb_list_add (current_statement->body, x)
77 #define cb_emit_list(l) \
78  current_statement->body = cb_list_append (current_statement->body, l)
79 
80 /* Global variables */
81 
82 cb_tree cb_debug_item;
83 cb_tree cb_debug_line;
84 cb_tree cb_debug_name;
85 cb_tree cb_debug_sub_1;
86 cb_tree cb_debug_sub_2;
87 cb_tree cb_debug_sub_3;
88 cb_tree cb_debug_contents;
89 
90 size_t suppress_warn = 0;
91 
92 /* Local variables */
93 
94 static cb_tree decimal_stack = NULL;
95 
96 static const char *inspect_func;
97 static cb_tree inspect_data;
98 
99 static int expr_op; /* Last operator */
100 static cb_tree expr_lh; /* Last left hand */
101 
102 static size_t initialized = 0;
103 static size_t overlapping = 0;
104 
105 static int expr_index; /* Stack index */
106 static int expr_stack_size; /* Stack max size */
107 static struct expr_node *expr_stack; /* Expression node stack */
108 
109 static const unsigned char hexval[] = "0123456789ABCDEF";
110 
111 #ifdef HAVE_DESIGNATED_INITS
112 static const unsigned char expr_prio[256] = {
113  ['x'] = 0,
114  ['^'] = 1,
115  ['*'] = 2,
116  ['/'] = 2,
117  ['+'] = 3,
118  ['-'] = 3,
119  ['='] = 4,
120  ['~'] = 4,
121  ['<'] = 4,
122  ['>'] = 4,
123  ['['] = 4,
124  [']'] = 4,
125  ['!'] = 5,
126  ['&'] = 6,
127  ['|'] = 7,
128  [')'] = 8,
129  ['('] = 9,
130  [0] = 10
131 };
132 
133 static const unsigned char valid_char[256] = {
134  ['0'] = 1,
135  ['1'] = 1,
136  ['2'] = 1,
137  ['3'] = 1,
138  ['4'] = 1,
139  ['5'] = 1,
140  ['6'] = 1,
141  ['7'] = 1,
142  ['8'] = 1,
143  ['9'] = 1,
144  ['A'] = 1,
145  ['B'] = 1,
146  ['C'] = 1,
147  ['D'] = 1,
148  ['E'] = 1,
149  ['F'] = 1,
150  ['G'] = 1,
151  ['H'] = 1,
152  ['I'] = 1,
153  ['J'] = 1,
154  ['K'] = 1,
155  ['L'] = 1,
156  ['M'] = 1,
157  ['N'] = 1,
158  ['O'] = 1,
159  ['P'] = 1,
160  ['Q'] = 1,
161  ['R'] = 1,
162  ['S'] = 1,
163  ['T'] = 1,
164  ['U'] = 1,
165  ['V'] = 1,
166  ['W'] = 1,
167  ['X'] = 1,
168  ['Y'] = 1,
169  ['Z'] = 1,
170  ['_'] = 1,
171  ['a'] = 1,
172  ['b'] = 1,
173  ['c'] = 1,
174  ['d'] = 1,
175  ['e'] = 1,
176  ['f'] = 1,
177  ['g'] = 1,
178  ['h'] = 1,
179  ['i'] = 1,
180  ['j'] = 1,
181  ['k'] = 1,
182  ['l'] = 1,
183  ['m'] = 1,
184  ['n'] = 1,
185  ['o'] = 1,
186  ['p'] = 1,
187  ['q'] = 1,
188  ['r'] = 1,
189  ['s'] = 1,
190  ['t'] = 1,
191  ['u'] = 1,
192  ['v'] = 1,
193  ['w'] = 1,
194  ['x'] = 1,
195  ['y'] = 1,
196  ['z'] = 1
197 };
198 #else
199 static unsigned char expr_prio[256];
200 static unsigned char valid_char[256];
201 static const unsigned char pvalid_char[] =
202  "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz";
203 #endif
204 
205 /* EBCDIC referring to ASCII */
206 static const unsigned char cob_refer_ascii[256] = {
207  0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,
208  0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
209  0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,
210  0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
211  0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,
212  0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
213  0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,
214  0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
215  0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,
216  0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
217  0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,
218  0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,
219  0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,
220  0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
221  0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,
222  0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,
223  0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,
224  0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,
225  0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,
226  0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,
227  0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,
228  0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,
229  0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,
230  0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,
231  0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,
232  0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,
233  0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,
234  0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,
235  0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,
236  0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,
237  0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,
238  0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF
239 };
240 
241 /* ASCII referring to EBCDIC */
242 static const unsigned char cob_refer_ebcdic[256] = {
243  0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,
244  0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
245  0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,
246  0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,
247  0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,
248  0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,
249  0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,
250  0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,
251  0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,
252  0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,
253  0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,
254  0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,
255  0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,
256  0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
257  0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,
258  0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
259  0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
260  0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,
261  0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,
262  0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,
263  0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,
264  0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,
265  0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,
266  0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,
267  0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,
268  0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,
269  0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,
270  0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,
271  0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,
272  0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,
273  0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,
274  0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF
275 };
276 
277 /* System routines */
278 
279 #undef COB_SYSTEM_GEN
280 #define COB_SYSTEM_GEN(x, y, z) { x, y },
281 
282 static const struct system_table system_tab[] = {
283 #include "libcob/system.def"
284  { NULL, 0 }
285 };
286 
287 #undef COB_SYSTEM_GEN
288 
289 static const struct optim_table bin_set_funcs[] = {
290  { NULL, COB_OPTIM_MIN },
291  { "cob_setswp_u16", COB_SETSWP_U16 },
292  { "cob_setswp_u24", COB_SETSWP_U24 },
293  { "cob_setswp_u32", COB_SETSWP_U32 },
294  { "cob_setswp_u40", COB_SETSWP_U40 },
295  { "cob_setswp_u48", COB_SETSWP_U48 },
296  { "cob_setswp_u56", COB_SETSWP_U56 },
297  { "cob_setswp_u64", COB_SETSWP_U64 },
298  { NULL, COB_OPTIM_MIN },
299  { "cob_setswp_s16", COB_SETSWP_S16 },
300  { "cob_setswp_s24", COB_SETSWP_S24 },
301  { "cob_setswp_s32", COB_SETSWP_S32 },
302  { "cob_setswp_s40", COB_SETSWP_S40 },
303  { "cob_setswp_s48", COB_SETSWP_S48 },
304  { "cob_setswp_s56", COB_SETSWP_S56 },
305  { "cob_setswp_s64", COB_SETSWP_S64 }
306 };
307 
308 static const struct optim_table bin_compare_funcs[] = {
309  { "cob_cmp_u8", COB_CMP_U8 },
310  { "cob_cmp_u16", COB_CMP_U16 },
311  { "cob_cmp_u24", COB_CMP_U24 },
312  { "cob_cmp_u32", COB_CMP_U32 },
313  { "cob_cmp_u40", COB_CMP_U40 },
314  { "cob_cmp_u48", COB_CMP_U48 },
315  { "cob_cmp_u56", COB_CMP_U56 },
316  { "cob_cmp_u64", COB_CMP_U64 },
317  { "cob_cmp_s8", COB_CMP_S8 },
318  { "cob_cmp_s16", COB_CMP_S16 },
319  { "cob_cmp_s24", COB_CMP_S24 },
320  { "cob_cmp_s32", COB_CMP_S32 },
321  { "cob_cmp_s40", COB_CMP_S40 },
322  { "cob_cmp_s48", COB_CMP_S48 },
323  { "cob_cmp_s56", COB_CMP_S56 },
324  { "cob_cmp_s64", COB_CMP_S64 },
325  { "cob_cmp_u8", COB_CMP_U8 },
326  { "cob_cmpswp_u16", COB_CMPSWP_U16 },
327  { "cob_cmpswp_u24", COB_CMPSWP_U24 },
328  { "cob_cmpswp_u32", COB_CMPSWP_U32 },
329  { "cob_cmpswp_u40", COB_CMPSWP_U40 },
330  { "cob_cmpswp_u48", COB_CMPSWP_U48 },
331  { "cob_cmpswp_u56", COB_CMPSWP_U56 },
332  { "cob_cmpswp_u64", COB_CMPSWP_U64 },
333  { "cob_cmp_s8", COB_CMP_S8 },
334  { "cob_cmpswp_s16", COB_CMPSWP_S16 },
335  { "cob_cmpswp_s24", COB_CMPSWP_S24 },
336  { "cob_cmpswp_s32", COB_CMPSWP_S32 },
337  { "cob_cmpswp_s40", COB_CMPSWP_S40 },
338  { "cob_cmpswp_s48", COB_CMPSWP_S48 },
339  { "cob_cmpswp_s56", COB_CMPSWP_S56 },
340  { "cob_cmpswp_s64", COB_CMPSWP_S64 }
341 };
342 
343 static const struct optim_table bin_add_funcs[] = {
344  { "cob_add_u8", COB_ADD_U8 },
345  { "cob_add_u16", COB_ADD_U16 },
346  { "cob_add_u24", COB_ADD_U24 },
347  { "cob_add_u32", COB_ADD_U32 },
348  { "cob_add_u40", COB_ADD_U40 },
349  { "cob_add_u48", COB_ADD_U48 },
350  { "cob_add_u56", COB_ADD_U56 },
351  { "cob_add_u64", COB_ADD_U64 },
352  { "cob_add_s8", COB_ADD_S8 },
353  { "cob_add_s16", COB_ADD_S16 },
354  { "cob_add_s24", COB_ADD_S24 },
355  { "cob_add_s32", COB_ADD_S32 },
356  { "cob_add_s40", COB_ADD_S40 },
357  { "cob_add_s48", COB_ADD_S48 },
358  { "cob_add_s56", COB_ADD_S56 },
359  { "cob_add_s64", COB_ADD_S64 },
360  { "cob_add_u8", COB_ADD_U8 },
361  { "cob_addswp_u16", COB_ADDSWP_U16 },
362  { "cob_addswp_u24", COB_ADDSWP_U24 },
363  { "cob_addswp_u32", COB_ADDSWP_U32 },
364  { "cob_addswp_u40", COB_ADDSWP_U40 },
365  { "cob_addswp_u48", COB_ADDSWP_U48 },
366  { "cob_addswp_u56", COB_ADDSWP_U56 },
367  { "cob_addswp_u64", COB_ADDSWP_U64 },
368  { "cob_add_s8", COB_ADD_S8 },
369  { "cob_addswp_s16", COB_ADDSWP_S16 },
370  { "cob_addswp_s24", COB_ADDSWP_S24 },
371  { "cob_addswp_s32", COB_ADDSWP_S32 },
372  { "cob_addswp_s40", COB_ADDSWP_S40 },
373  { "cob_addswp_s48", COB_ADDSWP_S48 },
374  { "cob_addswp_s56", COB_ADDSWP_S56 },
375  { "cob_addswp_s64", COB_ADDSWP_S64 }
376 };
377 
378 static const struct optim_table bin_sub_funcs[] = {
379  { "cob_sub_u8", COB_SUB_U8 },
380  { "cob_sub_u16", COB_SUB_U16 },
381  { "cob_sub_u24", COB_SUB_U24 },
382  { "cob_sub_u32", COB_SUB_U32 },
383  { "cob_sub_u40", COB_SUB_U40 },
384  { "cob_sub_u48", COB_SUB_U48 },
385  { "cob_sub_u56", COB_SUB_U56 },
386  { "cob_sub_u64", COB_SUB_U64 },
387  { "cob_sub_s8", COB_SUB_S8 },
388  { "cob_sub_s16", COB_SUB_S16 },
389  { "cob_sub_s24", COB_SUB_S24 },
390  { "cob_sub_s32", COB_SUB_S32 },
391  { "cob_sub_s40", COB_SUB_S40 },
392  { "cob_sub_s48", COB_SUB_S48 },
393  { "cob_sub_s56", COB_SUB_S56 },
394  { "cob_sub_s64", COB_SUB_S64 },
395  { "cob_sub_u8", COB_SUB_U8 },
396  { "cob_subswp_u16", COB_SUBSWP_U16 },
397  { "cob_subswp_u24", COB_SUBSWP_U24 },
398  { "cob_subswp_u32", COB_SUBSWP_U32 },
399  { "cob_subswp_u40", COB_SUBSWP_U40 },
400  { "cob_subswp_u48", COB_SUBSWP_U48 },
401  { "cob_subswp_u56", COB_SUBSWP_U56 },
402  { "cob_subswp_u64", COB_SUBSWP_U64 },
403  { "cob_sub_s8", COB_SUB_S8 },
404  { "cob_subswp_s16", COB_SUBSWP_S16 },
405  { "cob_subswp_s24", COB_SUBSWP_S24 },
406  { "cob_subswp_s32", COB_SUBSWP_S32 },
407  { "cob_subswp_s40", COB_SUBSWP_S40 },
408  { "cob_subswp_s48", COB_SUBSWP_S48 },
409  { "cob_subswp_s56", COB_SUBSWP_S56 },
410  { "cob_subswp_s64", COB_SUBSWP_S64 }
411 };
412 
413 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
414 static const struct optim_table align_bin_compare_funcs[] = {
415  { "cob_cmp_u8", COB_CMP_U8 },
416  { "cob_cmp_align_u16", COB_CMP_ALIGN_U16 },
417  { "cob_cmp_u24", COB_CMP_U24 },
418  { "cob_cmp_align_u32", COB_CMP_ALIGN_U32 },
419  { "cob_cmp_u40", COB_CMP_U40 },
420  { "cob_cmp_u48", COB_CMP_U48 },
421  { "cob_cmp_u56", COB_CMP_U56 },
422  { "cob_cmp_align_u64", COB_CMP_ALIGN_U64 },
423  { "cob_cmp_s8", COB_CMP_S8 },
424  { "cob_cmp_align_s16", COB_CMP_ALIGN_S16 },
425  { "cob_cmp_s24", COB_CMP_S24 },
426  { "cob_cmp_align_s32", COB_CMP_ALIGN_S32 },
427  { "cob_cmp_s40", COB_CMP_S40 },
428  { "cob_cmp_s48", COB_CMP_S48 },
429  { "cob_cmp_s56", COB_CMP_S56 },
430  { "cob_cmp_align_s64", COB_CMP_ALIGN_S64 },
431  { "cob_cmp_u8", COB_CMP_U8 },
432  { "cob_cmpswp_align_u16", COB_CMPSWP_ALIGN_U16 },
433  { "cob_cmpswp_u24", COB_CMPSWP_U24 },
434  { "cob_cmpswp_align_u32", COB_CMPSWP_ALIGN_U32 },
435  { "cob_cmpswp_u40", COB_CMPSWP_U40 },
436  { "cob_cmpswp_u48", COB_CMPSWP_U48 },
437  { "cob_cmpswp_u56", COB_CMPSWP_U56 },
438  { "cob_cmpswp_align_u64", COB_CMPSWP_ALIGN_U64 },
439  { "cob_cmp_s8", COB_CMP_S8 },
440  { "cob_cmpswp_align_s16", COB_CMPSWP_ALIGN_S16 },
441  { "cob_cmpswp_s24", COB_CMPSWP_S24 },
442  { "cob_cmpswp_align_s32", COB_CMPSWP_ALIGN_S32 },
443  { "cob_cmpswp_s40", COB_CMPSWP_S40 },
444  { "cob_cmpswp_s48", COB_CMPSWP_S48 },
445  { "cob_cmpswp_s56", COB_CMPSWP_S56 },
446  { "cob_cmpswp_align_s64", COB_CMPSWP_ALIGN_S64 },
447 };
448 
449 static const struct optim_table align_bin_add_funcs[] = {
450  { "cob_add_u8", COB_ADD_U8 },
451  { "cob_add_align_u16", COB_ADD_ALIGN_U16 },
452  { "cob_add_u24", COB_ADD_U24 },
453  { "cob_add_align_u32", COB_ADD_ALIGN_U32 },
454  { "cob_add_u40", COB_ADD_U40 },
455  { "cob_add_u48", COB_ADD_U48 },
456  { "cob_add_u56", COB_ADD_U56 },
457  { "cob_add_align_u64", COB_ADD_ALIGN_U64 },
458  { "cob_add_s8", COB_ADD_S8 },
459  { "cob_add_align_s16", COB_ADD_ALIGN_S16 },
460  { "cob_add_s24", COB_ADD_S24 },
461  { "cob_add_align_s32", COB_ADD_ALIGN_S32 },
462  { "cob_add_s40", COB_ADD_S40 },
463  { "cob_add_s48", COB_ADD_S48 },
464  { "cob_add_s56", COB_ADD_S56 },
465  { "cob_add_align_s64", COB_ADD_ALIGN_S64 },
466  { "cob_add_u8", COB_ADD_U8 },
467  { "cob_addswp_u16", COB_ADDSWP_U16 },
468  { "cob_addswp_u24", COB_ADDSWP_U24 },
469  { "cob_addswp_u32", COB_ADDSWP_U32 },
470  { "cob_addswp_u40", COB_ADDSWP_U40 },
471  { "cob_addswp_u48", COB_ADDSWP_U48 },
472  { "cob_addswp_u56", COB_ADDSWP_U56 },
473  { "cob_addswp_u64", COB_ADDSWP_U64 },
474  { "cob_add_s8", COB_ADD_S8 },
475  { "cob_addswp_s16", COB_ADDSWP_S16 },
476  { "cob_addswp_s24", COB_ADDSWP_S24 },
477  { "cob_addswp_s32", COB_ADDSWP_S32 },
478  { "cob_addswp_s40", COB_ADDSWP_S40 },
479  { "cob_addswp_s48", COB_ADDSWP_S48 },
480  { "cob_addswp_s56", COB_ADDSWP_S56 },
481  { "cob_addswp_s64", COB_ADDSWP_S64 },
482 };
483 
484 static const struct optim_table align_bin_sub_funcs[] = {
485  { "cob_sub_u8", COB_SUB_U8 },
486  { "cob_sub_align_u16", COB_SUB_ALIGN_U16 },
487  { "cob_sub_u24", COB_SUB_U24 },
488  { "cob_sub_align_u32", COB_SUB_ALIGN_U32 },
489  { "cob_sub_u40", COB_SUB_U40 },
490  { "cob_sub_u48", COB_SUB_U48 },
491  { "cob_sub_u56", COB_SUB_U56 },
492  { "cob_sub_align_u64", COB_SUB_ALIGN_U64 },
493  { "cob_sub_s8", COB_SUB_S8 },
494  { "cob_sub_align_s16", COB_SUB_ALIGN_S16 },
495  { "cob_sub_s24", COB_SUB_S24 },
496  { "cob_sub_align_s32", COB_SUB_ALIGN_S32 },
497  { "cob_sub_s40", COB_SUB_S40 },
498  { "cob_sub_s48", COB_SUB_S48 },
499  { "cob_sub_s56", COB_SUB_S56 },
500  { "cob_sub_align_s64", COB_SUB_ALIGN_S64 },
501  { "cob_sub_u8", COB_SUB_U8 },
502  { "cob_subswp_u16", COB_SUBSWP_U16 },
503  { "cob_subswp_u24", COB_SUBSWP_U24 },
504  { "cob_subswp_u32", COB_SUBSWP_U32 },
505  { "cob_subswp_u40", COB_SUBSWP_U40 },
506  { "cob_subswp_u48", COB_SUBSWP_U48 },
507  { "cob_subswp_u56", COB_SUBSWP_U56 },
508  { "cob_subswp_u64", COB_SUBSWP_U64 },
509  { "cob_sub_s8", COB_SUB_S8 },
510  { "cob_subswp_s16", COB_SUBSWP_S16 },
511  { "cob_subswp_s24", COB_SUBSWP_S24 },
512  { "cob_subswp_s32", COB_SUBSWP_S32 },
513  { "cob_subswp_s40", COB_SUBSWP_S40 },
514  { "cob_subswp_s48", COB_SUBSWP_S48 },
515  { "cob_subswp_s56", COB_SUBSWP_S56 },
516  { "cob_subswp_s64", COB_SUBSWP_S64 },
517 };
518 #endif
519 
520 /* Functions */
521 
522 static cb_tree
523 cb_check_needs_break (cb_tree stmt)
524 {
525  cb_tree l;
526 
527  /* Check if last statement is GO TO */
528  for (l = stmt; l; l = CB_CHAIN (l)) {
529  if (!CB_CHAIN(l)) {
530  break;
531  }
532  }
533  if (l && CB_VALUE (l) && CB_STATEMENT_P (CB_VALUE (l))) {
534  l = CB_STATEMENT(CB_VALUE(l))->body;
535  if (l && CB_VALUE (l) && !CB_GOTO_P (CB_VALUE(l))) {
536  /* Append a break */
537  l = cb_build_direct ("break;", 0);
538  return cb_list_add (stmt, l);
539  }
540  }
541  return stmt;
542 }
543 
544 static size_t
545 cb_validate_one (cb_tree x)
546 {
547  cb_tree y;
548  struct cb_field *f;
549 
550  if (x == cb_error_node) {
551  return 1;
552  }
553  if (!x) {
554  return 0;
555  }
556  if (CB_REFERENCE_P (x)) {
557  y = cb_ref (x);
558  if (y == cb_error_node) {
559  return 1;
560  }
561  if (CB_FIELD_P (y)) {
562  f = CB_FIELD (y);
563  if (f->level == 88) {
564  cb_error_x (x, _("Invalid use of 88 level item"));
565  return 1;
566  }
567  if (f->flag_invalid) {
568  return 1;
569  }
570  /* check for nested ODO */
571  if (f->odo_level > 1) {
572  cb_error_x (x, _("'%s' not implemented"),
573  _("Reference to item containing nested ODO"));
574  }
575  }
576  }
577  return 0;
578 }
579 
580 static size_t
581 cb_validate_list (cb_tree l)
582 {
583  for (; l; l = CB_CHAIN (l)) {
584  if (cb_validate_one (CB_VALUE (l))) {
585  return 1;
586  }
587  }
588  return 0;
589 }
590 
591 static cb_tree
592 cb_check_group_name (cb_tree x)
593 {
594  cb_tree y;
595 
596  if (x == cb_error_node) {
597  return cb_error_node;
598  }
599 
600  if (CB_REFERENCE_P (x)) {
601  y = cb_ref (x);
602  if (y == cb_error_node) {
603  return cb_error_node;
604  }
605  if (CB_FIELD_P (y) && CB_FIELD (y)->children != NULL &&
606  CB_REFERENCE (x)->offset == NULL) {
607  return x;
608  }
609  }
610 
611  cb_error_x (x, _("'%s' is not group name"), cb_name (x));
612  return cb_error_node;
613 }
614 
615 static cb_tree
616 cb_check_numeric_name (cb_tree x)
617 {
618  if (x == cb_error_node) {
619  return cb_error_node;
620  }
621 
622  if (CB_REFERENCE_P (x) &&
623  CB_FIELD_P (cb_ref (x)) &&
624  CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
625  return x;
626  }
627 
628  cb_error_x (x, _("'%s' is not a numeric name"), cb_name (x));
629  return cb_error_node;
630 }
631 
632 static cb_tree
633 cb_check_numeric_edited_name (cb_tree x)
634 {
635  if (x == cb_error_node) {
636  return cb_error_node;
637  }
638 
639  if (CB_REFERENCE_P (x) &&
640  CB_FIELD_P (cb_ref (x)) &&
641  (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC ||
642  CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC_EDITED)) {
643  return x;
644  }
645 
646  cb_error_x (x, _("'%s' is not numeric or numeric-edited name"), cb_name (x));
647  return cb_error_node;
648 }
649 
650 cb_tree
651 cb_check_numeric_value (cb_tree x)
652 {
653  if (x == cb_error_node) {
654  return cb_error_node;
655  }
656 
657  if (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
658  return x;
659  }
660 
661  cb_error_x (x, _("'%s' is not a numeric value"), cb_name (x));
662  return cb_error_node;
663 }
664 
665 static cb_tree
666 cb_check_integer_value (cb_tree x)
667 {
668  struct cb_literal *l;
669  struct cb_field *f;
670  cb_tree y;
671 
672  if (x == cb_error_node) {
673  return cb_error_node;
674  }
675 
676  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
677  goto invalid;
678  }
679 
680  switch (CB_TREE_TAG (x)) {
681  case CB_TAG_CONST:
682  if (x != cb_zero) {
683  goto invalid;
684  }
685  return x;
686  case CB_TAG_LITERAL:
687  l = CB_LITERAL (x);
688  if (l->sign < 0 || l->scale > 0) {
689  goto invliteral;
690  }
691  return x;
692  case CB_TAG_REFERENCE:
693  y = cb_ref (x);
694  if (y == cb_error_node) {
695  return cb_error_node;
696  }
697  f = CB_FIELD (y);
698  if (f->pic->scale > 0) {
699  goto invalid;
700  }
701  return x;
702  case CB_TAG_BINARY_OP:
703  /* TODO: need to check */
704  return x;
705  case CB_TAG_INTRINSIC:
706  /* TODO: need to check */
707  return x;
708  default:
709 invalid:
710  cb_error_x (x, _("'%s' is not an integer value"), cb_name (x));
711  return cb_error_node;
712  }
713 invliteral:
714  cb_error_x (x, _("A positive numeric integer is required here"));
715  return cb_error_node;
716 }
717 
718 static void
719 cb_check_data_incompat (cb_tree x)
720 {
721  struct cb_field *f;
722 
723  if (!x || x == cb_error_node) {
724  return;
725  }
726  if (!CB_REF_OR_FIELD_P (x) ||
727  CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
728  return;
729  }
730  f = CB_FIELD_PTR (x);
731  if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
732  cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
733  }
734  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
735  if (f->usage == CB_USAGE_DISPLAY ||
736  f->usage == CB_USAGE_PACKED ||
737  f->usage == CB_USAGE_COMP_6) {
738  cb_emit (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
739  x,
740  CB_BUILD_STRING0 (f->name)));
741  }
742  }
743 }
744 
745 static void
746 cb_check_lit_subs (struct cb_reference *r, const int numsubs,
747  const int numindex)
748 {
749  cb_tree l;
750  cb_tree v;
751  struct cb_literal *lt;
752  int size;
753 
754  /* Check for DPC and non-standard separator usage */
755  if (!cb_relaxed_syntax_check ||
756  current_program->decimal_point != ',') {
757  return;
758  }
759  if (numsubs > numindex) {
760  return;
761  }
762 
763  for (l = r->subs; l; l = CB_CHAIN (l)) {
764  v = CB_VALUE (l);
765  if (v == cb_error_node) {
766  continue;
767  }
768  if (!CB_LITERAL_P (v)) {
769  continue;
770  }
771  lt = CB_LITERAL (v);
772  if (!lt->scale) {
773  continue;
774  }
775  if (lt->scale == (int)lt->size) {
776  lt->scale = 0;
777  continue;
778  }
779  size = lt->size - lt->scale;
780  v = cb_build_numsize_literal (&lt->data[size],
781  (size_t)lt->scale, lt->sign);
782  CB_VALUE (l) = v;
783  v = cb_build_numsize_literal (lt->data, (size_t)size, 0);
784  CB_CHAIN (l) = CB_BUILD_CHAIN (v, CB_CHAIN (l));
785  }
786  return;
787 }
788 
789 static int
790 cb_field_size (const cb_tree x)
791 {
792  struct cb_reference *r;
793  struct cb_field *f;
794 
795  switch (CB_TREE_TAG (x)) {
796  case CB_TAG_LITERAL:
797  return CB_LITERAL (x)->size;
798  case CB_TAG_FIELD:
799  return CB_FIELD (x)->size;
800  case CB_TAG_REFERENCE:
801  r = CB_REFERENCE (x);
802  f = CB_FIELD (r->value);
803 
804  if (r->length) {
805  if (CB_LITERAL_P (r->length)) {
806  return cb_get_int (r->length);
807  } else {
808  return -1;
809  }
810  } else if (r->offset) {
811  if (CB_LITERAL_P (r->offset)) {
812  return f->size - cb_get_int (r->offset) + 1;
813  } else {
814  return -1;
815  }
816  } else {
817  return f->size;
818  }
819  default:
820  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
821  /* Use dumb variant */
822  COBC_DUMB_ABORT ();
823  }
824  /* NOT REACHED */
825 #ifndef _MSC_VER
826  return 0;
827 #endif
828 }
829 
830 /* List system routines */
831 
832 void
833 cb_list_system (void)
834 {
835  const struct system_table *psyst;
836  const char *s;
837  size_t n;
838 
839  putchar ('\n');
840  printf (_("System routine\t\t\tParameters"));
841  puts ("\n");
842  for (psyst = system_tab; psyst->syst_name; psyst++) {
843  switch (*(unsigned char *)(psyst->syst_name)) {
844  case 'C':
845  case 'S':
846  printf ("%s", psyst->syst_name);
847  break;
848  case 0xF4:
849  printf ("X\"F4\"");
850  break;
851  case 0xF5:
852  printf ("X\"F5\"");
853  break;
854  case 0x91:
855  printf ("X\"91\"");
856  break;
857  case 0xE4:
858  printf ("X\"E4\"");
859  break;
860  case 0xE5:
861  printf ("X\"E5\"");
862  break;
863  default:
864  break;
865  }
866  n = strlen (psyst->syst_name);
867  switch (n / 8) {
868  case 0:
869  s = "\t\t\t\t";
870  break;
871  case 1:
872  s = "\t\t\t";
873  break;
874  case 2:
875  s = "\t\t";
876  break;
877  default:
878  s = "\t";
879  break;
880  }
881  printf ("%s%d\n", s, psyst->syst_params);
882  }
883 }
884 
885 /* Check if tree is an INDEX */
886 size_t
887 cb_check_index_p (cb_tree x)
888 {
889  struct cb_field *f;
890 
891  if (!CB_REF_OR_FIELD_P (x)) {
892  return 0;
893  }
894  f = CB_FIELD_PTR (x);
895  if (f->usage == CB_USAGE_INDEX && !f->children) {
896  return 1;
897  }
898  return 0;
899 }
900 
901 /* Check if a field reference requires debugging */
902 
903 void
904 cb_check_field_debug (cb_tree fld)
905 {
906  cb_tree l;
907  cb_tree x;
908  cb_tree z;
909  size_t size;
910  size_t found;
911  char buff[COB_MINI_BUFF];
912 
913  /* Basic reference check */
914  if (CB_WORD_COUNT (fld) > 0) {
915  if (!CB_WORD_ITEMS (fld)) {
916  return;
917  }
918  z = CB_VALUE(CB_WORD_ITEMS (fld));
919  if (!CB_FIELD_P (z)) {
920  return;
921  }
922  x = cb_ref (fld);
923  if (x == cb_error_node) {
924  return;
925  }
926  } else {
927  return;
928  }
929 
930  found = 0;
931  /* Check if reference is being debugged */
932  for (l = current_program->debug_list; l; l = CB_CHAIN (l)) {
933  if (!CB_PURPOSE (l)) {
934  continue;
935  }
936  if (x == CB_PURPOSE (l)) {
937  if (CB_REFERENCE (fld)->flag_target ||
938  CB_REFERENCE (CB_VALUE (l))->flag_all_debug) {
939  found = 1;
940  }
941  break;
942  }
943  }
944  if (!found) {
945  return;
946  }
947 
948  found = 0;
949  /* Found it - check if it is already in the statement list */
950  for (l = current_statement->debug_nodups; l; l = CB_CHAIN (l)) {
951  if (CB_VALUE (l) == x) {
952  found = 1;
953  break;
954  }
955  }
956  if (found) {
957  return;
958  }
959 
960  /* Set up debug info */
961  strcpy (buff, CB_FIELD(x)->name);
962  size = strlen (buff);
963  for (l = CB_REFERENCE (fld)->chain; l; l = CB_REFERENCE (l)->chain) {
964  z = cb_ref (l);
965  if (z != cb_error_node) {
966  size += strlen (CB_FIELD (z)->name);
967  size += 4;
968  if (size >= sizeof(buff)) {
969  break;
970  }
971  strcat (buff, " OF ");
972  strcat (buff, CB_FIELD (z)->name);
973  }
974  }
975  current_statement->debug_nodups =
976  cb_list_add (current_statement->debug_nodups, x);
977  current_statement->debug_check =
978  cb_list_add (current_statement->debug_check,
979  cb_build_debug (cb_debug_name, buff, NULL));
980  current_statement->debug_check =
981  cb_list_add (current_statement->debug_check,
982  cb_build_debug (cb_debug_contents, NULL, fld));
983  found = 0;
984  CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
985  l = CB_REFERENCE (fld)->subs;
986  for (; l && found < 3; l = CB_CHAIN (l), ++found) {
987  switch (found) {
988  case 0:
989  current_statement->debug_check =
990  cb_list_add (current_statement->debug_check,
991  cb_build_move (CB_VALUE (l),
992  cb_debug_sub_1));
993  break;
994  case 1:
995  current_statement->debug_check =
996  cb_list_add (current_statement->debug_check,
997  cb_build_move (CB_VALUE (l),
998  cb_debug_sub_2));
999  break;
1000  case 2:
1001  current_statement->debug_check =
1002  cb_list_add (current_statement->debug_check,
1003  cb_build_move (CB_VALUE (l),
1004  cb_debug_sub_3));
1005  break;
1006  default:
1007  break;
1008  }
1009  }
1010  CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
1011 
1012  for (; found < 3; ++found) {
1013  switch (found) {
1014  case 0:
1015  current_statement->debug_check =
1016  cb_list_add (current_statement->debug_check,
1017  CB_BUILD_FUNCALL_3 ("memset",
1018  CB_BUILD_CAST_ADDRESS (cb_debug_sub_1),
1019  cb_int (' '),
1020  CB_BUILD_CAST_LENGTH (cb_debug_sub_1)));
1021  break;
1022  case 1:
1023  current_statement->debug_check =
1024  cb_list_add (current_statement->debug_check,
1025  CB_BUILD_FUNCALL_3 ("memset",
1026  CB_BUILD_CAST_ADDRESS (cb_debug_sub_2),
1027  cb_int (' '),
1028  CB_BUILD_CAST_LENGTH (cb_debug_sub_2)));
1029  break;
1030  case 2:
1031  current_statement->debug_check =
1032  cb_list_add (current_statement->debug_check,
1033  CB_BUILD_FUNCALL_3 ("memset",
1034  CB_BUILD_CAST_ADDRESS (cb_debug_sub_3),
1035  cb_int (' '),
1036  CB_BUILD_CAST_LENGTH (cb_debug_sub_3)));
1037  break;
1038  default:
1039  break;
1040  }
1041  }
1042 
1043  current_statement->debug_check =
1044  cb_list_add (current_statement->debug_check,
1045  cb_build_debug_call (CB_FIELD(x)->debug_section));
1046 }
1047 
1048 /* Program registers */
1049 
1050 void
1051 cb_build_registers (void)
1052 {
1053 #if !defined(__linux__) && !defined(__CYGWIN__) && defined(HAVE_TIMEZONE)
1054  long contz;
1055 #endif
1056  cb_tree r;
1057  cb_tree x;
1058  struct tm *tlt;
1059  time_t t;
1060  char buff[48];
1061 
1062  /* RETURN-CODE */
1063  if (!current_program->nested_level) {
1064  x = cb_build_index (cb_build_reference ("RETURN-CODE"),
1065  cb_zero, 0, NULL);
1066  CB_FIELD_PTR (x)->special_index = 1;
1067  current_program->cb_return_code = x;
1068  }
1069 
1070  /* SORT-RETURN */
1071  x = cb_build_index (cb_build_reference ("SORT-RETURN"),
1072  cb_zero, 0, NULL);
1073  CB_FIELD_PTR (x)->flag_no_init = 1;
1074  current_program->cb_sort_return = x;
1075 
1076  /* NUMBER-OF-CALL-PARAMETERS */
1077  x = cb_build_index (cb_build_reference ("NUMBER-OF-CALL-PARAMETERS"),
1078  cb_zero, 0, NULL);
1079  CB_FIELD_PTR (x)->flag_no_init = 1;
1080  CB_FIELD_PTR (x)->flag_local = 1;
1081  CB_FIELD_PTR (x)->special_index = 2;
1082  current_program->cb_call_params = x;
1083 
1084  /* TALLY */
1085  if (current_program->nested_level == 0) {
1086  r = cb_build_reference ("TALLY");
1087  x = cb_build_field (r);
1088  CB_FIELD_PTR (x)->usage = CB_USAGE_BINARY;
1089  CB_FIELD_PTR (x)->pic = CB_PICTURE (cb_build_picture ("9(5)"));
1090  cb_validate_field (CB_FIELD_PTR (x));
1091  CB_FIELD_PTR (x)->values = CB_LIST_INIT (cb_zero);
1092  CB_FIELD_PTR (x)->flag_no_init = 1;
1093  CB_FIELD_PTR (x)->flag_is_global = 1;
1094  CB_FIELD_ADD (current_program->working_storage, CB_FIELD_PTR (x));
1095  }
1096 
1097  t = time (NULL);
1098  tlt = localtime (&t);
1099  /* Leap seconds ? */
1100  if (tlt->tm_sec >= 60) {
1101  tlt->tm_sec = 59;
1102  }
1103 
1104  /* WHEN-COMPILED */
1105  memset (buff, 0, sizeof (buff));
1106  strftime (buff, (size_t)17, "%m/%d/%y%H.%M.%S", tlt);
1107  cb_build_constant (cb_build_reference ("WHEN-COMPILED"),
1108  cb_build_alphanumeric_literal (buff, (size_t)16));
1109 
1110  /* FUNCTION WHEN-COMPILED */
1111  memset (buff, 0, sizeof (buff));
1112 #if defined(__linux__) || defined(__CYGWIN__)
1113  strftime (buff, (size_t)22, "%Y%m%d%H%M%S00%z", tlt);
1114 #elif defined(HAVE_TIMEZONE)
1115  strftime (buff, (size_t)17, "%Y%m%d%H%M%S00", tlt);
1116  if (timezone <= 0) {
1117  contz = -timezone;
1118  buff[16] = '+';
1119  } else {
1120  contz = timezone;
1121  buff[16] = '-';
1122  }
1123  sprintf (&buff[17], "%2.2ld%2.2ld", contz / 3600, contz % 60);
1124 #else
1125  strftime (buff, (size_t)22, "%Y%m%d%H%M%S0000000", tlt);
1126 #endif
1127  cb_intr_whencomp = cb_build_alphanumeric_literal (buff, (size_t)21);
1128 
1129 }
1130 
1131 char *
1132 cb_encode_program_id (const char *name)
1133 {
1134  unsigned char *p;
1135  const unsigned char *s;
1136  const unsigned char *t;
1137  unsigned char buff[COB_MINI_BUFF];
1138 
1139  s = NULL;
1140  for (t = (const unsigned char *)name; *t; t++) {
1141  if (*t == (unsigned char)'/' || *t == (unsigned char)'\\') {
1142  s = t + 1;
1143  }
1144  }
1145  if (!s) {
1146  s = (const unsigned char *)name;
1147  }
1148  p = buff;
1149  /* Encode the initial digit */
1150  if (*s <= (unsigned char)'9' && *s >= (unsigned char)'0') {
1151  *p++ = (unsigned char)'_';
1152  }
1153  /* Encode invalid letters */
1154  for (; *s; s++) {
1155  if (likely(valid_char[*s])) {
1156  *p++ = *s;
1157  } else {
1158  *p++ = (unsigned char)'_';
1159  if (*s == (unsigned char)'-') {
1160  *p++ = (unsigned char)'_';
1161  } else {
1162  *p++ = hexval[*s / 16U];
1163  *p++ = hexval[*s % 16U];
1164  }
1165  }
1166  }
1167  *p = 0;
1168 
1169  /* Check case folding */
1170  if (unlikely(cb_fold_call)) {
1171  if (cb_fold_call == COB_FOLD_UPPER) {
1172  for (p = buff; *p; p++) {
1173  if (islower (*p)) {
1174  *p = (cob_u8_t)toupper (*p);
1175  }
1176  }
1177  } else if (cb_fold_call == COB_FOLD_LOWER) {
1178  for (p = buff; *p; p++) {
1179  if (isupper (*p)) {
1180  *p = (cob_u8_t)tolower (*p);
1181  }
1182  }
1183  }
1184  }
1185 
1186  return cobc_check_string ((char *)buff);
1187 }
1188 
1189 char *
1190 cb_build_program_id (cb_tree name, cb_tree alt_name, const cob_u32_t is_func)
1191 {
1192  const char *name_str;
1193  char *s;
1194  unsigned char *p;
1195 
1196  /* Set the program name */
1197  if (CB_LITERAL_P (name)) {
1198  current_program->program_name = (char *)CB_LITERAL (name)->data;
1199  } else {
1200  current_program->program_name = CB_NAME (name);
1201  }
1202 
1203  /* Set and encode the PROGRAM-ID */
1204  if (alt_name) {
1205  name_str = (const char *)CB_LITERAL (alt_name)->data;
1206  } else if (CB_LITERAL_P (name)) {
1207  name_str = (const char *)CB_LITERAL (name)->data;
1208  } else {
1209  name_str = CB_NAME (name);
1210  }
1211  current_program->orig_program_id = cobc_strdup (name_str);
1212  s = cb_encode_program_id (name_str);
1213 
1214  (void)cobc_check_valid_name (current_program->orig_program_id, 2U);
1215 
1216  /* Convert function names to upper case */
1217  if (is_func) {
1218  for (p = (unsigned char *)s; *p; ++p) {
1219  if (islower ((int)*p)) {
1220  *p = (cob_u8_t)toupper ((int)*p);
1221  }
1222  }
1223  }
1224  return s;
1225 }
1226 
1227 cb_tree
1228 cb_define_switch_name (cb_tree name, cb_tree sname, const int flag)
1229 {
1230  cb_tree switch_id;
1231  cb_tree value;
1232 
1233  if (!name || name == cb_error_node) {
1234  return NULL;
1235  }
1236  if (!sname || sname == cb_error_node ||
1237  CB_SYSTEM_NAME (sname)->category != CB_SWITCH_NAME) {
1238  cb_error_x (name, _("ON/OFF usage requires a SWITCH name"));
1239  return NULL;
1240  }
1241  switch_id = cb_int (CB_SYSTEM_NAME (sname)->token);
1242  value = CB_BUILD_FUNCALL_1 ("cob_get_switch", switch_id);
1243  if (flag == 0) {
1244  value = CB_BUILD_NEGATION (value);
1245  }
1246  cb_build_constant (name, value);
1247  return value;
1248 }
1249 
1250 cb_tree
1251 cb_build_section_name (cb_tree name, const int sect_or_para)
1252 {
1253  cb_tree x;
1254 
1255  if (name == cb_error_node) {
1256  return cb_error_node;
1257  }
1258 
1259  if (CB_WORD_COUNT (name) > 0) {
1260  x = CB_VALUE (CB_WORD_ITEMS (name));
1261  /* Used as a non-label name or used as a section name.
1262  Duplicate paragraphs are allowed if not referenced;
1263  Checked in typeck.c */
1264  if (!CB_LABEL_P (x) || sect_or_para == 0 ||
1265  (sect_or_para && CB_LABEL_P (x) &&
1266  CB_LABEL (x)->flag_section)) {
1267  redefinition_error (name);
1268  return cb_error_node;
1269  }
1270  }
1271 
1272  return name;
1273 }
1274 
1275 cb_tree
1276 cb_build_assignment_name (struct cb_file *cfile, cb_tree name)
1277 {
1278  const char *s;
1279  const char *p;
1280 
1281  if (name == cb_error_node) {
1282  return cb_error_node;
1283  }
1284  /* For special assignment */
1285  if (name == NULL) {
1286  return NULL;
1287  }
1288 
1289  switch (CB_TREE_TAG (name)) {
1290  case CB_TAG_LITERAL:
1291  return name;
1292 
1293  case CB_TAG_REFERENCE:
1294  s = CB_NAME (name);
1295  if (cb_assign_clause == CB_ASSIGN_MF) {
1296  if (cfile->flag_ext_assign) {
1297  p = strrchr (s, '-');
1298  if (p) {
1299  s = p + 1;
1300  }
1301  return cb_build_alphanumeric_literal (s, strlen (s));
1302  }
1303  current_program->reference_list =
1304  cb_list_add (current_program->reference_list, name);
1305  return name;
1306  } else if (cb_assign_clause == CB_ASSIGN_IBM) {
1307  /* Check organization */
1308  if (strncmp (s, "S-", (size_t)2) == 0 ||
1309  strncmp (s, "AS-", (size_t)3) == 0) {
1310  goto org;
1311  }
1312  /* Skip the device label if exists */
1313  if ((p = strchr (s, '-')) != NULL) {
1314  s = p + 1;
1315  }
1316  /* Check organization again */
1317  if (strncmp (s, "S-", (size_t)2) == 0 ||
1318  strncmp (s, "AS-", (size_t)3) == 0) {
1319 org:
1320  /* Skip it for now */
1321  s = strchr (s, '-') + 1;
1322  }
1323  /* Convert the name into literal */
1324  if (warningopt) {
1325  cb_warning (_("ASSIGN interpreted as %s"), s);
1326  }
1327  return cb_build_alphanumeric_literal (s, strlen (s));
1328  }
1329  /* Fall through for CB_ASSIGN_COBOL2002 */
1330  /* To be looked at */
1331  default:
1332  return cb_error_node;
1333  }
1334 }
1335 
1336 cb_tree
1337 cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by,
1338  struct cb_field *qual)
1339 {
1340  struct cb_field *f;
1341 
1342  f = CB_FIELD (cb_build_field (x));
1343  f->usage = CB_USAGE_INDEX;
1344  cb_validate_field (f);
1345  if (values) {
1346  f->values = CB_LIST_INIT (values);
1347  }
1348  if (qual) {
1349  f->index_qual = qual;
1350  }
1351  f->flag_indexed_by = !!indexed_by;
1352  CB_FIELD_ADD (current_program->working_storage, f);
1353  return x;
1354 }
1355 
1356 cb_tree
1357 cb_build_address (cb_tree x)
1358 {
1359  cb_tree v;
1360  struct cb_reference *r;
1361  const char *name;
1362  int numsubs;
1363  int refsubs;
1364 
1365  if (x == cb_error_node) {
1366  return cb_error_node;
1367  }
1368  if (!CB_REFERENCE_P (x)) {
1369  return CB_BUILD_CAST_ADDRESS (x);
1370  }
1371 
1372  r = CB_REFERENCE (x);
1373  name = r->word->name;
1374  v = cb_ref (x);
1375  if (v == cb_error_node) {
1376  return cb_error_node;
1377  }
1378 
1379  refsubs = cb_list_length (r->subs);
1380  if (CB_FIELD_P (v)) {
1381  numsubs = CB_FIELD (v)->indexes;
1382  if (refsubs > numsubs) {
1383  goto subserror;
1384  } else if (refsubs < numsubs) {
1385  if (!cb_relaxed_syntax_check) {
1386  goto subserror;
1387  } else {
1388  cb_warning_x (x,
1389  _("Subscripts missing for '%s' - Defaulting to 1"),
1390  name);
1391  for (; refsubs < numsubs; ++refsubs) {
1392  CB_ADD_TO_CHAIN (cb_one, r->subs);
1393  }
1394  }
1395  }
1396  } else {
1397  numsubs = 0;
1398  if (r->subs) {
1399  goto subserror;
1400  }
1401  if (r->offset) {
1402  cb_error_x (x, _("'%s' cannot be reference modified"), name);
1403  return cb_error_node;
1404  }
1405  }
1406 
1407  return CB_BUILD_CAST_ADDRESS (x);
1408 
1409 subserror:
1410  switch (numsubs) {
1411  case 0:
1412  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1413  break;
1414  case 1:
1415  cb_error_x (x, _("'%s' requires 1 subscript"), name);
1416  break;
1417  default:
1418  cb_error_x (x, _("'%s' requires %d subscripts"),
1419  name, numsubs);
1420  break;
1421  }
1422  return cb_error_node;
1423 }
1424 
1425 cb_tree
1426 cb_build_identifier (cb_tree x, const int subchk)
1427 {
1428  struct cb_reference *r;
1429  struct cb_field *f;
1430  struct cb_field *p;
1431  const char *name;
1432  char full_name[COB_MAX_WORDLEN * 2 + 10];
1433  cb_tree xr;
1434  cb_tree v;
1435  cb_tree e1;
1436  cb_tree l;
1437  cb_tree sub;
1438  int offset;
1439  int length;
1440  int n;
1441  int numsubs;
1442  int refsubs;
1443  int pseudosize;
1444 
1445  if (x == cb_error_node) {
1446  return cb_error_node;
1447  }
1448 
1449  r = CB_REFERENCE (x);
1450  name = r->word->name;
1451 
1452  /* Resolve reference */
1453  v = cb_ref (x);
1454  if (v == cb_error_node) {
1455  return cb_error_node;
1456  }
1457 
1458  /* Check if it is a data name */
1459  if (!CB_FIELD_P (v)) {
1460  if (r->subs) {
1461  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1462  return cb_error_node;
1463  }
1464  if (r->offset) {
1465  cb_error_x (x, _("'%s' cannot be reference modified"), name);
1466  return cb_error_node;
1467  }
1468  return x;
1469  }
1470  f = CB_FIELD (v);
1471 
1472  /* BASED check and check for OPTIONAL LINKAGE items */
1473  if (current_statement &&
1474  (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL) ||
1475  CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED))) {
1476  p = cb_field_founder (f);
1477  if (p->redefines) {
1478  p = p->redefines;
1479  }
1480  if (p == f) {
1481  sprintf(full_name, "'%s'", name);
1482  } else {
1483  sprintf(full_name, _("'%s' (accessed by '%s')"), p->name, name);
1484  }
1485  xr = cb_build_reference(full_name);
1486 
1487  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL) &&
1488  !current_statement->flag_no_based) {
1489  if (p->flag_item_based ||
1490  (p->storage == CB_STORAGE_LINKAGE &&
1491  !p->flag_is_pdiv_parm)) {
1492  current_statement->null_check = CB_BUILD_FUNCALL_2 (
1493  "cob_check_based",
1494  cb_build_address (cb_build_field_reference (p, NULL)),
1495  CB_BUILD_STRING0 (CB_REFERENCE(xr)->word->name));
1496  }
1497  }
1498  if (CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED) &&
1499  p->flag_is_pdiv_opt) {
1500  current_statement->null_check = CB_BUILD_FUNCALL_3 (
1501  "cob_check_linkage",
1502  cb_build_address (cb_build_field_reference (p, NULL)),
1503  CB_BUILD_STRING0 (CB_REFERENCE(xr)->word->name), cb_int1);
1504  }
1505  }
1506 
1507  for (l = r->subs; l; l = CB_CHAIN (l)) {
1508  if (CB_BINARY_OP_P (CB_VALUE (l))) {
1509  /* Set special flag for codegen */
1510  CB_BINARY_OP(CB_VALUE(l))->flag = 1;
1511  }
1512  }
1513 
1514  /* Check the number of subscripts */
1515  numsubs = refsubs = cb_list_length (r->subs);
1516  cb_check_lit_subs (r, numsubs, f->indexes);
1517  if (subchk) {
1518  if (!f->indexes) {
1519  cb_error_x (x, _("'%s' has no OCCURS clause"), name);
1520  return cb_error_node;
1521  }
1522  numsubs = f->indexes - 1;
1523  } else {
1524  numsubs = f->indexes;
1525  }
1526  if (unlikely(!r->flag_all)) {
1527  if (refsubs != numsubs) {
1528  if (refsubs > numsubs) {
1529  goto refsubserr;
1530  } else if (refsubs < numsubs) {
1531  if (!cb_relaxed_syntax_check) {
1532  goto refsubserr;
1533  } else {
1534  cb_warning_x (x,
1535  _("Subscripts missing for '%s' - Defaulting to 1"),
1536  name);
1537  for (; refsubs < numsubs; ++refsubs) {
1538  CB_ADD_TO_CHAIN (cb_one, r->subs);
1539  }
1540  }
1541  }
1542  }
1543 
1544  /* Run-time check for ODO (including all the fields subordinate items) */
1545  if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT) && f->odo_level != 0) {
1546  for (p = f; p; p = p->children) {
1547  if (p->depending) {
1548  e1 = CB_BUILD_FUNCALL_4 ("cob_check_odo",
1549  cb_build_cast_int (p->depending),
1550  cb_int (p->occurs_min),
1551  cb_int (p->occurs_max),
1552  CB_BUILD_STRING0
1553  ((CB_FIELD_PTR (p->depending)->name)));
1554  r->check = cb_list_add (r->check, e1);
1555  }
1556  }
1557  }
1558 
1559  /* Subscript check along with setting of table offset */
1560  if (r->subs) {
1561  l = r->subs;
1562  for (p = f; p; p = p->parent) {
1563  if (!p->flag_occurs) {
1564  continue;
1565  }
1566 
1567 #if 1 /* RXWRXW - Sub check */
1568  if (!l) {
1569  break;
1570  }
1571 #endif
1572  sub = cb_check_integer_value (CB_VALUE (l));
1573  l = CB_CHAIN (l);
1574  if (sub == cb_error_node) {
1575  continue;
1576  }
1577 
1578  /* Compile-time check for all literals */
1579  if (CB_LITERAL_P (sub)) {
1580  n = cb_get_int (sub);
1581  if (n < 1 || n > p->occurs_max) {
1582  cb_error_x (x, _("Subscript of '%s' out of bounds: %d"),
1583  name, n);
1584  }
1585  if (p==f) {
1586  /* Only valid for single subscript (!) */
1587  f->mem_offset = f->size * (n - 1);
1588  }
1589  }
1590 
1591  /* Run-time check for all non-literals */
1592  if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
1593  if (p->depending) {
1594  e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
1595  cb_build_cast_int (sub),
1596  cb_int1,
1597  cb_build_cast_int (p->depending),
1598  CB_BUILD_STRING0 (name));
1599  r->check = cb_list_add (r->check, e1);
1600  } else {
1601  if (!CB_LITERAL_P (sub)) {
1602  e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
1603  cb_build_cast_int (sub),
1604  cb_int1,
1605  cb_int (p->occurs_max),
1606  CB_BUILD_STRING0 (name));
1607  r->check = cb_list_add (r->check, e1);
1608  }
1609  }
1610  }
1611  }
1612  }
1613 
1614  }
1615 
1616  if (subchk) {
1617  r->subs = cb_list_reverse (r->subs);
1618  r->subs = cb_list_add (r->subs, cb_int1);
1619  r->subs = cb_list_reverse (r->subs);
1620  }
1621 
1622  /* Reference modification check */
1623  if ( f->usage == CB_USAGE_NATIONAL ) {
1624  pseudosize = f->size / 2;
1625  } else {
1626  pseudosize = f->size;
1627  }
1628  if (r->offset) {
1629  /* Compile-time check */
1630  if (CB_LITERAL_P (r->offset)) {
1631  offset = cb_get_int (r->offset);
1632  if (f->flag_any_length) {
1633  if (offset < 1) {
1634  cb_error_x (x, _("Offset of '%s' out of bounds: %d"), name, offset);
1635  } else if (r->length && CB_LITERAL_P (r->length)) {
1636  length = cb_get_int (r->length);
1637  if (length < 1) {
1638  cb_error_x (x, _("Length of '%s' out of bounds: %d"),
1639  name, length);
1640  }
1641  }
1642  } else {
1643  if (offset < 1 || offset > pseudosize) {
1644  cb_error_x (x, _("Offset of '%s' out of bounds: %d"), name, offset);
1645  } else if (r->length && CB_LITERAL_P (r->length)) {
1646  length = cb_get_int (r->length);
1647  if (length < 1 || length > pseudosize - offset + 1) {
1648  cb_error_x (x, _("Length of '%s' out of bounds: %d"),
1649  name, length);
1650  }
1651  }
1652  }
1653  }
1654 
1655  /* Run-time check */
1656  if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) {
1657  if (f->flag_any_length || !CB_LITERAL_P (r->offset) ||
1658  (r->length && !CB_LITERAL_P (r->length))) {
1659  e1 = CB_BUILD_FUNCALL_4 ("cob_check_ref_mod",
1660  cb_build_cast_int (r->offset),
1661  r->length ?
1662  cb_build_cast_int (r->length) :
1663  cb_int1,
1664  f->flag_any_length ?
1665  CB_BUILD_CAST_LENGTH (v) :
1666  cb_int (pseudosize),
1667  CB_BUILD_STRING0 (f->name));
1668  r->check = cb_list_add (r->check, e1);
1669  }
1670  }
1671  }
1672 
1673  if (f->storage == CB_STORAGE_CONSTANT) {
1674  return CB_VALUE (f->values);
1675  }
1676 
1677  return x;
1678 
1679 refsubserr:
1680  switch (numsubs) {
1681  case 0:
1682  cb_error_x (x, _("'%s' cannot be subscripted"), name);
1683  break;
1684  case 1:
1685  cb_error_x (x, _("'%s' requires 1 subscript"), name);
1686  break;
1687  default:
1688  cb_error_x (x, _("'%s' requires %d subscripts"),
1689  name, f->indexes);
1690  break;
1691  }
1692  return cb_error_node;
1693 }
1694 
1695 static cb_tree
1696 cb_build_length_1 (cb_tree x)
1697 {
1698  struct cb_field *f;
1699  cb_tree e;
1700  cb_tree size;
1701 
1702  f = CB_FIELD (cb_ref (x));
1703 
1704  if (cb_field_variable_size (f) == NULL) {
1705  /* Constant size */
1706  return cb_int (cb_field_size (x));
1707  }
1708  /* Variable size */
1709  e = NULL;
1710  for (f = f->children; f; f = f->sister) {
1711  size = cb_build_length_1 (cb_build_field_reference (f, x));
1712  if (f->depending) {
1713  if (!cb_flag_odoslide && f->flag_odo_relative) {
1714  size = cb_build_binary_op (size, '*',
1715  cb_int (f->occurs_max));
1716  } else {
1717  size = cb_build_binary_op (size, '*',
1718  f->depending);
1719  }
1720  } else if (f->occurs_max > 1) {
1721  size = cb_build_binary_op (size, '*',
1722  cb_int (f->occurs_max));
1723  }
1724  e = e ? cb_build_binary_op (e, '+', size) : size;
1725  }
1726  return e;
1727 }
1728 
1729 cb_tree
1730 cb_build_const_length (cb_tree x)
1731 {
1732  struct cb_field *f;
1733  char buff[32];
1734 
1735  if (x == cb_error_node) {
1736  return cb_error_node;
1737  }
1738  if (CB_INTEGER_P (x)) {
1739  sprintf (buff, "%d", CB_INTEGER(x)->val);
1740  return cb_build_numeric_literal (0, buff, 0);
1741  }
1742  if (CB_REFERENCE_P (x)) {
1743  if (cb_ref (x) == cb_error_node) {
1744  return cb_error_node;
1745  }
1746  if (CB_REFERENCE (x)->offset) {
1747  cb_error (_("Reference modification not allowed here"));
1748  return cb_error_node;
1749  }
1750  }
1751 
1752  memset (buff, 0, sizeof (buff));
1753  f = CB_FIELD (cb_ref (x));
1754  if (f->flag_any_length) {
1755  cb_error (_("ANY LENGTH item not allowed here"));
1756  return cb_error_node;
1757  }
1758  if (f->level == 88) {
1759  cb_error (_("88 level item not allowed here"));
1760  return cb_error_node;
1761  }
1762  if (cb_field_variable_size (f)) {
1763  cb_error (_("Variable length item not allowed here"));
1764  return cb_error_node;
1765  }
1766  if (f->redefines) {
1767  cb_validate_field (f->redefines);
1768  if (f->rename_thru) {
1769  cb_validate_field (f->rename_thru);
1770  }
1771  cb_validate_field (f);
1772  sprintf (buff, "%d", f->size);
1773  } else {
1774  cb_validate_field (f);
1775  sprintf (buff, "%d", f->memory_size);
1776  }
1777  return cb_build_numeric_literal (0, buff, 0);
1778 }
1779 
1780 cb_tree
1781 cb_build_length (cb_tree x)
1782 {
1783  struct cb_field *f;
1784  struct cb_literal *l;
1785  cb_tree temp;
1786  char buff[32];
1787 
1788  if (x == cb_error_node) {
1789  return cb_error_node;
1790  }
1791  if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
1792  return cb_error_node;
1793  }
1794 
1795  if (CB_LITERAL_P (x)) {
1796  l = CB_LITERAL (x);
1797  sprintf (buff, "%d", (int)l->size);
1798  return cb_build_numeric_literal (0, buff, 0);
1799  }
1800  if (CB_INTRINSIC_P (x)) {
1801  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1802  }
1803  if (CB_REF_OR_FIELD_P (x)) {
1804  if (CB_REFERENCE_P (x) && CB_REFERENCE (x)->offset) {
1805  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1806  }
1807  f = CB_FIELD (cb_ref (x));
1808  if (f->flag_any_length) {
1809  return cb_build_any_intrinsic (CB_LIST_INIT (x));
1810  }
1811  if (cb_field_variable_size (f) == NULL) {
1812  sprintf (buff, "%d", cb_field_size (x));
1813  return cb_build_numeric_literal (0, buff, 0);
1814  }
1815  }
1816  temp = cb_build_index (cb_build_filler (), NULL, 0, NULL);
1817  CB_FIELD (cb_ref (temp))->usage = CB_USAGE_LENGTH;
1818  CB_FIELD (cb_ref (temp))->count++;
1819  cb_emit (cb_build_assign (temp, cb_build_length_1 (x)));
1820  return temp;
1821 }
1822 
1823 cb_tree
1824 cb_build_ppointer (cb_tree x)
1825 {
1826  struct cb_field *f;
1827 
1828  if (x == cb_error_node ||
1829  (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
1830  return cb_error_node;
1831  }
1832 
1833  if (CB_REFERENCE_P (x)) {
1834  f = CB_FIELD_PTR (cb_ref(x));
1835  f->count++;
1836  }
1837  return CB_BUILD_CAST_PPOINTER (x);
1838 }
1839 
1840 /* Validate program */
1841 
1842 static int
1843 get_value (cb_tree x)
1844 {
1845  if (x == cb_space) {
1846  return ' ';
1847  } else if (x == cb_zero) {
1848  return '0';
1849  } else if (x == cb_quote) {
1850  return cb_flag_apostrophe ? '\'' : '"';
1851  } else if (x == cb_norm_low) {
1852  return 0;
1853  } else if (x == cb_norm_high) {
1854  return 255;
1855  } else if (x == cb_null) {
1856  return 0;
1857  } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
1858  return cb_get_int (x) - 1;
1859  }
1860  return CB_LITERAL (x)->data[0];
1861 }
1862 
1863 static void
1864 cb_validate_collating (struct cb_program *prog)
1865 {
1866  cb_tree x;
1867 
1868  x = cb_ref (prog->collating_sequence);
1869  if (!CB_ALPHABET_NAME_P (x)) {
1870  cb_error_x (prog->collating_sequence, _("'%s' is not an alphabet name"),
1871  cb_name (prog->collating_sequence));
1872  prog->collating_sequence = NULL;
1873  return;
1874  }
1875  if (CB_ALPHABET_NAME (x)->alphabet_type != CB_ALPHABET_CUSTOM) {
1876  return;
1877  }
1878  if (CB_ALPHABET_NAME (x)->low_val_char) {
1879  cb_low = cb_build_alphanumeric_literal ("\0", (size_t)1);
1880  CB_LITERAL(cb_low)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->low_val_char;
1881  CB_LITERAL(cb_low)->all = 1;
1882  }
1883  if (CB_ALPHABET_NAME (x)->high_val_char != 255){
1884  cb_high = cb_build_alphanumeric_literal ("\0", (size_t)1);
1885  CB_LITERAL(cb_high)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->high_val_char;
1886  CB_LITERAL(cb_high)->all = 1;
1887  }
1888 }
1889 
1890 void
1891 cb_validate_program_environment (struct cb_program *prog)
1892 {
1893  cb_tree x;
1894  cb_tree y;
1895  cb_tree l;
1896  cb_tree ls;
1897  struct cb_alphabet_name *ap;
1898  struct cb_class_name *cp;
1899  unsigned char *data;
1900  size_t dupls;
1901  size_t unvals;
1902  size_t count;
1903  int lower;
1904  int upper;
1905  int size;
1906  int n;
1907  int i;
1908  int lastval;
1909  int tableval;
1910  int values[256];
1911  int charvals[256];
1912 
1913  /* Check ALPHABET clauses */
1914  /* Complicated by difference between code set and collating sequence */
1915  for (l = current_program->alphabet_name_list; l; l = CB_CHAIN (l)) {
1916  ap = CB_ALPHABET_NAME (CB_VALUE (l));
1917 
1918  /* Native */
1919  if (ap->alphabet_type == CB_ALPHABET_NATIVE) {
1920  for (n = 0; n < 256; n++) {
1921  ap->values[n] = n;
1922  ap->alphachr[n] = n;
1923  }
1924  continue;
1925  }
1926 
1927  /* ASCII */
1928  if (ap->alphabet_type == CB_ALPHABET_ASCII) {
1929  for (n = 0; n < 256; n++) {
1930 #ifdef COB_EBCDIC_MACHINE
1931  ap->values[n] = (int)cob_refer_ascii[n];
1932  ap->alphachr[n] = (int)cob_refer_ascii[n];
1933 #else
1934  ap->values[n] = n;
1935  ap->alphachr[n] = n;
1936 #endif
1937  }
1938  continue;
1939  }
1940 
1941  /* EBCDIC */
1942  if (ap->alphabet_type == CB_ALPHABET_EBCDIC) {
1943  for (n = 0; n < 256; n++) {
1944 #ifdef COB_EBCDIC_MACHINE
1945  ap->values[n] = n;
1946  ap->alphachr[n] = n;
1947 #else
1948  ap->values[n] = (int)cob_refer_ebcdic[n];
1949  ap->alphachr[n] = (int)cob_refer_ebcdic[n];
1950 #endif
1951  }
1952  continue;
1953  }
1954 
1955  /* Custom alphabet */
1956  dupls = 0;
1957  unvals = 0;
1958  count = 0;
1959  lastval = 0;
1960  tableval = 0;
1961  for (n = 0; n < 256; n++) {
1962  values[n] = -1;
1963  charvals[n] = -1;
1964  ap->values[n] = -1;
1965  ap->alphachr[n] = -1;
1966  }
1967  ap->low_val_char = 0;
1968  ap->high_val_char = 255;
1969  for (y = ap->custom_list; y; y = CB_CHAIN (y)) {
1970  if (count > 255) {
1971  unvals = 1;
1972  break;
1973  }
1974  x = CB_VALUE (y);
1975  if (CB_PAIR_P (x)) {
1976  /* X THRU Y */
1977  lower = get_value (CB_PAIR_X (x));
1978  upper = get_value (CB_PAIR_Y (x));
1979  lastval = upper;
1980  if (!count) {
1981  ap->low_val_char = lower;
1982  }
1983  if (lower < 0 || lower > 255) {
1984  unvals = 1;
1985  continue;
1986  }
1987  if (upper < 0 || upper > 255) {
1988  unvals = 1;
1989  continue;
1990  }
1991  if (lower <= upper) {
1992  for (i = lower; i <= upper; i++) {
1993  if (values[i] != -1) {
1994  dupls = 1;
1995  }
1996  values[i] = i;
1997  charvals[i] = i;
1998  ap->alphachr[tableval] = i;
1999  ap->values[i] = tableval++;
2000  count++;
2001  }
2002  } else {
2003  for (i = lower; i >= upper; i--) {
2004  if (values[i] != -1) {
2005  dupls = 1;
2006  }
2007  values[i] = i;
2008  charvals[i] = i;
2009  ap->alphachr[tableval] = i;
2010  ap->values[i] = tableval++;
2011  count++;
2012  }
2013  }
2014  } else if (CB_LIST_P (x)) {
2015  /* X ALSO Y ... */
2016  if (!count) {
2017  ap->low_val_char = get_value (CB_VALUE (x));
2018  }
2019  for (ls = x; ls; ls = CB_CHAIN (ls)) {
2020  n = get_value (CB_VALUE (ls));
2021  if (!CB_CHAIN (ls)) {
2022  lastval = n;
2023  }
2024  if (n < 0 || n > 255) {
2025  unvals = 1;
2026  continue;
2027  }
2028  if (values[n] != -1) {
2029  dupls = 1;
2030  }
2031  values[n] = n;
2032  ap->values[n] = tableval;
2033  if (ls == x) {
2034  ap->alphachr[tableval] = n;
2035  charvals[n] = n;
2036  }
2037  count++;
2038  }
2039  tableval++;
2040  } else {
2041  /* Literal */
2042  if (CB_NUMERIC_LITERAL_P (x)) {
2043  n = get_value (x);
2044  lastval = n;
2045  if (!count) {
2046  ap->low_val_char = n;
2047  }
2048  if (n < 0 || n > 255) {
2049  unvals = 1;
2050  continue;
2051  }
2052  if (values[n] != -1) {
2053  dupls = 1;
2054  }
2055  values[n] = n;
2056  charvals[n] = n;
2057  ap->alphachr[tableval] = n;
2058  ap->values[n] = tableval++;
2059  count++;
2060  } else if (CB_LITERAL_P (x)) {
2061  size = (int)CB_LITERAL (x)->size;
2062  data = CB_LITERAL (x)->data;
2063  if (!count) {
2064  ap->low_val_char = data[0];
2065  }
2066  lastval = data[size - 1];
2067  for (i = 0; i < size; i++) {
2068  n = data[i];
2069  if (values[n] != -1) {
2070  dupls = 1;
2071  }
2072  values[n] = n;
2073  charvals[n] = n;
2074  ap->alphachr[tableval] = n;
2075  ap->values[n] = tableval++;
2076  count++;
2077  }
2078  } else {
2079  n = get_value (x);
2080  lastval = n;
2081  if (!count) {
2082  ap->low_val_char = n;
2083  }
2084  if (n < 0 || n > 255) {
2085  unvals = 1;
2086  continue;
2087  }
2088  if (values[n] != -1) {
2089  dupls = 1;
2090  }
2091  values[n] = n;
2092  charvals[n] = n;
2093  ap->alphachr[tableval] = n;
2094  ap->values[n] = tableval++;
2095  count++;
2096  }
2097  }
2098  }
2099  if (dupls || unvals) {
2100  if (dupls) {
2101  cb_error_x (l, _("Duplicate character values in alphabet '%s'"),
2102  cb_name (CB_VALUE(l)));
2103  }
2104  if (unvals) {
2105  cb_error_x (l, _("Invalid character values in alphabet '%s'"),
2106  cb_name (CB_VALUE(l)));
2107  }
2108  ap->low_val_char = 0;
2109  ap->high_val_char = 255;
2110  continue;
2111  }
2112  /* Calculate HIGH-VALUE */
2113  /* If all 256 values have been specified, */
2114  /* HIGH-VALUE is the last one */
2115  /* Otherwise if HIGH-VALUE has been specified, find the highest */
2116  /* value that has not been used */
2117  if (count == 256) {
2118  ap->high_val_char = lastval;
2119  } else if (values[255] != -1) {
2120  for (n = 254; n >= 0; n--) {
2121  if (values[n] == -1) {
2122  ap->high_val_char = n;
2123  break;
2124  }
2125  }
2126  }
2127 
2128  /* Get rest of code set */
2129  for (n = tableval; n < 256; ++n) {
2130  for (i = 0; i < 256; ++i) {
2131  if (charvals[i] < 0) {
2132  charvals[i] = 0;
2133  ap->alphachr[n] = i;
2134  break;
2135  }
2136  }
2137  }
2138 
2139  /* Fill in missing characters */
2140  for (n = 0; n < 256; n++) {
2141  if (ap->values[n] < 0) {
2142  ap->values[n] = tableval++;
2143  }
2144  }
2145  }
2146 
2147  /* Reset HIGH/LOW-VALUES */
2148  cb_low = cb_norm_low;
2149  cb_high = cb_norm_high;
2150 
2151  /* Check and generate SYMBOLIC clauses */
2152  for (l = current_program->symbolic_char_list; l; l = CB_CHAIN (l)) {
2153  if (CB_VALUE (l)) {
2154  y = cb_ref (CB_VALUE (l));
2155  if (y == cb_error_node) {
2156  continue;
2157  }
2158  if (!CB_ALPHABET_NAME_P (y)) {
2159  cb_error_x (y, _("Invalid ALPHABET name"));
2160  continue;
2161  }
2162  } else {
2163  y = NULL;
2164  }
2165  cb_build_symbolic_chars (CB_PURPOSE (l), y);
2166  }
2167 
2168  /* Check CLASS clauses */
2169  for (l = current_program->class_name_list; l; l = CB_CHAIN (l)) {
2170  dupls = 0;
2171  memset (values, 0, sizeof(values));
2172  cp = CB_CLASS_NAME (CB_VALUE (l));
2173  for (y = cp->list; y; y = CB_CHAIN (y)) {
2174  x = CB_VALUE (y);
2175  if (CB_PAIR_P (x)) {
2176  /* X THRU Y */
2177  lower = get_value (CB_PAIR_X (x));
2178  upper = get_value (CB_PAIR_Y (x));
2179  for (i = lower; i <= upper; i++) {
2180  if (values[i]) {
2181  dupls = 1;
2182  }
2183  values[i] = 1;
2184  }
2185  } else {
2186  if (CB_NUMERIC_LITERAL_P (x)) {
2187  n = get_value (x);
2188  if (values[n]) {
2189  dupls = 1;
2190  }
2191  values[n] = 1;
2192  } else if (CB_LITERAL_P (x)) {
2193  size = (int)CB_LITERAL (x)->size;
2194  data = CB_LITERAL (x)->data;
2195  for (i = 0; i < size; i++) {
2196  n = data[i];
2197  if (values[n]) {
2198  dupls = 1;
2199  }
2200  values[n] = 1;
2201  }
2202  } else {
2203  n = get_value (x);
2204  if (values[n]) {
2205  dupls = 1;
2206  }
2207  values[n] = 1;
2208  }
2209  }
2210  }
2211  if (dupls) {
2212  if (!cb_relaxed_syntax_check) {
2213  cb_error_x (CB_VALUE(l),
2214  _("Duplicate values in class '%s'"),
2215  cb_name (CB_VALUE(l)));
2216  } else {
2217  cb_warning_x (CB_VALUE(l),
2218  _("Duplicate values in class '%s'"),
2219  cb_name (CB_VALUE(l)));
2220  }
2221  }
2222  }
2223 
2224  /* Resolve the program collating sequence */
2225  if (prog->collating_sequence) {
2226  cb_validate_collating (prog);
2227  }
2228 
2229  /* Resolve the program classification */
2230  if (prog->classification && prog->classification != cb_int1) {
2231  x = cb_ref (prog->classification);
2232  if (!CB_LOCALE_NAME_P (x)) {
2233  cb_error_x (prog->classification,
2234  _("'%s' is not a locale name"),
2235  cb_name (prog->classification));
2236  prog->classification = NULL;
2237  return;
2238  }
2239  }
2240 }
2241 
2242 void
2243 cb_build_debug_item (void)
2244 {
2245  cb_tree l;
2246  cb_tree x;
2247  cb_tree assign;
2248 
2249  /* Set up DEBUG-ITEM */
2250  l = cb_build_reference ("DEBUG-ITEM");
2251  assign = cb_build_field_tree (NULL, l, NULL, CB_STORAGE_WORKING,
2252  NULL, 1);
2253  CB_FIELD (assign)->values = CB_LIST_INIT (cb_space);
2254  cb_debug_item = l;
2255 
2256  l = cb_build_reference ("DEBUG-LINE");
2257  x = cb_build_field_tree (NULL, l, CB_FIELD(assign),
2258  CB_STORAGE_WORKING, NULL, 3);
2259  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("9(6)"));
2260  cb_validate_field (CB_FIELD (x));
2261  cb_debug_line = l;
2262 
2263  l = cb_build_filler ();
2264  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2265  CB_STORAGE_WORKING, NULL, 3);
2266  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2267  CB_FIELD (x)->flag_filler = 1;
2268  cb_validate_field (CB_FIELD (x));
2269 
2270  l = cb_build_reference ("DEBUG-NAME");
2271  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2272  CB_STORAGE_WORKING, NULL, 3);
2273  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
2274  cb_validate_field (CB_FIELD (x));
2275  cb_debug_name = l;
2276 
2277  l = cb_build_filler ();
2278  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2279  CB_STORAGE_WORKING, NULL, 3);
2280  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2281  CB_FIELD (x)->flag_filler = 1;
2282  cb_validate_field (CB_FIELD (x));
2283 
2284  l = cb_build_reference ("DEBUG-SUB-1");
2285  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2286  CB_STORAGE_WORKING, NULL, 3);
2287  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2288  CB_FIELD (x)->flag_sign_leading = 1;
2289  CB_FIELD (x)->flag_sign_separate = 1;
2290  cb_validate_field (CB_FIELD (x));
2291  cb_debug_sub_1 = l;
2292 
2293  l = cb_build_filler ();
2294  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2295  CB_STORAGE_WORKING, NULL, 3);
2296  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2297  CB_FIELD (x)->flag_filler = 1;
2298  cb_validate_field (CB_FIELD (x));
2299 
2300  l = cb_build_reference ("DEBUG-SUB-2");
2301  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2302  CB_STORAGE_WORKING, NULL, 3);
2303  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2304  CB_FIELD (x)->flag_sign_leading = 1;
2305  CB_FIELD (x)->flag_sign_separate = 1;
2306  cb_validate_field (CB_FIELD (x));
2307  cb_debug_sub_2 = l;
2308 
2309  l = cb_build_filler ();
2310  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2311  CB_STORAGE_WORKING, NULL, 3);
2312  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2313  CB_FIELD (x)->flag_filler = 1;
2314  cb_validate_field (CB_FIELD (x));
2315 
2316  l = cb_build_reference ("DEBUG-SUB-3");
2317  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2318  CB_STORAGE_WORKING, NULL, 3);
2319  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2320  CB_FIELD (x)->flag_sign_leading = 1;
2321  CB_FIELD (x)->flag_sign_separate = 1;
2322  cb_validate_field (CB_FIELD (x));
2323  cb_debug_sub_3 = l;
2324 
2325  l = cb_build_filler ();
2326  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2327  CB_STORAGE_WORKING, NULL, 3);
2328  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2329  CB_FIELD (x)->flag_filler = 1;
2330  cb_validate_field (CB_FIELD (x));
2331 
2332  l = cb_build_reference ("DEBUG-CONTENTS");
2333  x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2334  CB_STORAGE_WORKING, NULL, 3);
2335  CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(31)"));
2336  cb_validate_field (CB_FIELD (x));
2337  cb_debug_contents = l;
2338 
2339  cb_validate_field (CB_FIELD (assign));
2340  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (assign));
2341 }
2342 
2343 void
2344 cb_validate_program_data (struct cb_program *prog)
2345 {
2346  cb_tree l;
2347  cb_tree x;
2348  cb_tree assign;
2349  struct cb_field *p;
2350  struct cb_field *q;
2351  struct cb_field *depfld;
2352  struct cb_file *f;
2353  struct cb_report *rep;
2354  unsigned char *c;
2355  char buff[COB_MINI_BUFF];
2356  unsigned int odo_level;
2357 
2358  for (l = current_program->report_list; l; l = CB_CHAIN (l)) {
2359  /* Set up LINE-COUNTER / PAGE-COUNTER */
2360  rep = CB_REPORT (CB_VALUE (l));
2361  snprintf (buff, (size_t)COB_MINI_MAX,
2362  "LINE-COUNTER %s", rep->cname);
2363  x = cb_build_field (cb_build_reference (buff));
2364  CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
2365  CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
2366  CB_FIELD (x)->count++;
2367  cb_validate_field (CB_FIELD (x));
2368  rep->line_counter = cb_build_field_reference (CB_FIELD (x), NULL);
2369  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
2370  snprintf (buff, (size_t)COB_MINI_MAX,
2371  "PAGE-COUNTER %s", rep->cname);
2372  x = cb_build_field (cb_build_reference (buff));
2373  CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
2374  CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
2375  CB_FIELD (x)->count++;
2376  cb_validate_field (CB_FIELD (x));
2377  rep->page_counter = cb_build_field_reference (CB_FIELD (x), NULL);
2378  CB_FIELD_ADD (current_program->working_storage, CB_FIELD (x));
2379  }
2380 
2381  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2382  f = CB_FILE (CB_VALUE (l));
2383  if (!f->flag_finalized) {
2384  finalize_file (f, NULL);
2385  }
2386  }
2387 
2388  /* Build undeclared assignment name now */
2389  if (cb_assign_clause == CB_ASSIGN_MF) {
2390  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2391  assign = CB_FILE (CB_VALUE (l))->assign;
2392  if (!assign) {
2393  continue;
2394  }
2395  if (CB_REFERENCE_P (assign)) {
2396  for (x = current_program->file_list; x; x = CB_CHAIN (x)) {
2397  if (!strcmp (CB_FILE (CB_VALUE (x))->name,
2398  CB_NAME (assign))) {
2399  redefinition_error (assign);
2400  }
2401  }
2402  p = check_level_78 (CB_NAME (assign));
2403  if (p) {
2404  c = (unsigned char *)CB_LITERAL(CB_VALUE(p->values))->data;
2405  assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen ((char *)c)));
2406  CB_FILE (CB_VALUE (l))->assign = assign;
2407  }
2408  }
2409  if (CB_REFERENCE_P (assign) &&
2410  CB_WORD_COUNT (assign) == 0) {
2411  if (cb_warn_implicit_define) {
2412  cb_warning (_("'%s' will be implicitly defined"), CB_NAME (assign));
2413  }
2414  x = cb_build_implicit_field (assign, COB_SMALL_BUFF);
2415  CB_FIELD (x)->count++;
2416  p = current_program->working_storage;
2417  if (p) {
2418  while (p->sister) {
2419  p = p->sister;
2420  }
2421  p->sister = CB_FIELD (x);
2422  } else {
2423  current_program->working_storage = CB_FIELD (x);
2424  }
2425  }
2426  if (CB_REFERENCE_P (assign)) {
2427  x = cb_ref (assign);
2428  if (CB_FIELD_P (x) && CB_FIELD (x)->level == 88) {
2429  cb_error_x (assign, _("ASSIGN data item '%s' invalid"), CB_NAME (assign));
2430  }
2431  }
2432  }
2433  }
2434 
2435  if (prog->cursor_pos) {
2436  x = cb_ref (prog->cursor_pos);
2437  if (x == cb_error_node) {
2438  prog->cursor_pos = NULL;
2439  } else if (CB_FIELD(x)->size != 6 && CB_FIELD(x)->size != 4) {
2440  cb_error_x (prog->cursor_pos, _("'%s' CURSOR is not 4 or 6 characters long"),
2441  cb_name (prog->cursor_pos));
2442  prog->cursor_pos = NULL;
2443  }
2444  }
2445  if (prog->crt_status) {
2446  x = cb_ref (prog->crt_status);
2447  if (x == cb_error_node) {
2448  prog->crt_status = NULL;
2449  } else if (CB_FIELD(x)->size != 4) {
2450  cb_error_x (prog->crt_status, _("'%s' CRT STATUS is not 4 characters long"),
2451  cb_name (prog->crt_status));
2452  prog->crt_status = NULL;
2453  }
2454  } else {
2455  l = cb_build_reference ("COB-CRT-STATUS");
2456  p = CB_FIELD (cb_build_field (l));
2457  p->usage = CB_USAGE_DISPLAY;
2458  p->pic = CB_PICTURE (cb_build_picture ("9(4)"));
2459  cb_validate_field (p);
2460  p->flag_no_init = 1;
2461  /* Do not initialize/bump ref count here
2462  p->values = CB_LIST_INIT (cb_zero);
2463  p->count++;
2464  */
2465  CB_FIELD_ADD (current_program->working_storage, p);
2466  prog->crt_status = l;
2467  }
2468 
2469  /* Resolve all references so far */
2470  for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
2471  cb_ref (CB_VALUE (l));
2472  }
2473 
2474  /* Check ODO items */
2475  for (l = cb_depend_check; l; l = CB_CHAIN (l)) {
2476  x = CB_VALUE(l);
2477  if (x == cb_error_node) {
2478  continue;
2479  }
2480  q = CB_FIELD_PTR (x);
2481  if (cb_ref (q->depending) != cb_error_node) {
2482  depfld = CB_FIELD_PTR (q->depending);
2483  } else {
2484  depfld = NULL;
2485  }
2486  /* The data item that contains a OCCURS DEPENDING clause must be
2487  the last data item in the group */
2488  odo_level = 0;
2489  for (p = q; ; p = p->parent) {
2490  if (p->depending) odo_level++;
2491  p->odo_level = odo_level;
2492  if (!p->parent) {
2493  break;
2494  }
2495  for (; p->sister; p = p->sister) {
2496  if (p->sister == depfld) {
2497  cb_error_x (x,
2498  _("'%s' ODO field item invalid here"),
2499  p->sister->name);
2500  }
2501  if (!p->sister->redefines) {
2502  if (!cb_complex_odo) {
2503  cb_error_x (x,
2504  _("'%s' cannot have OCCURS DEPENDING"),
2505  cb_name (x));
2506  break;
2507  }
2508  p->flag_odo_relative = 1;
2509  }
2510  }
2511  }
2512 
2513  /* If the field is GLOBAL, then the ODO must also be GLOBAL */
2514  if (q->flag_is_global && depfld) {
2515  if (!depfld->flag_is_global) {
2516  cb_error_x (x, _("'%s' ODO item must have GLOBAL attribute"),
2517  depfld->name);
2518  }
2519  }
2520  }
2521  cb_depend_check = NULL;
2522  cb_needs_01 = 0;
2523 
2524  for (l = current_program->file_list; l; l = CB_CHAIN (l)) {
2525  f = CB_FILE (CB_VALUE (l));
2526  if (CB_VALID_TREE(f->record_depending)) {
2527  x = f->record_depending;
2528  if (cb_ref (x) != cb_error_node) {
2529 #if 0 /* RXWRXW - This breaks old legacy programs */
2530  if (CB_REF_OR_FIELD_P(x)) {
2531  p = CB_FIELD_PTR (x);
2532  switch (p->storage) {
2533  case CB_STORAGE_WORKING:
2534  case CB_STORAGE_LOCAL:
2535  case CB_STORAGE_LINKAGE:
2536  break;
2537  default:
2538  cb_error (_("RECORD DEPENDING item must be in WORKING/LOCAL/LINKAGE section"));
2539  }
2540  } else {
2541 #endif
2542  if (!CB_REF_OR_FIELD_P(x)) {
2543  cb_error (_("Invalid RECORD DEPENDING item"));
2544  }
2545 #if 0 /* RXWRXW */
2546  }
2547 #endif
2548  }
2549  }
2550  }
2551 }
2552 
2553 void
2554 cb_validate_program_body (struct cb_program *prog)
2555 {
2556  cb_tree l;
2557  cb_tree x;
2558  cb_tree v;
2559  struct cb_label *save_section;
2560  struct cb_label *save_paragraph;
2561  struct cb_alter_id *aid;
2562  struct cb_label *l1;
2563  struct cb_label *l2;
2564  struct cb_field *f;
2565  int size;
2566 
2567  /* Resolve all labels */
2568  save_section = current_section;
2569  save_paragraph = current_paragraph;
2570  for (l = cb_list_reverse (prog->label_list); l; l = CB_CHAIN (l)) {
2571  x = CB_VALUE (l);
2572  current_section = CB_REFERENCE (x)->section;
2573  current_paragraph = CB_REFERENCE (x)->paragraph;
2574  v = cb_ref (x);
2575  /* Check refs in to / out of DECLARATIVES */
2576  if (CB_LABEL_P (v)) {
2577  if (CB_REFERENCE (x)->flag_in_decl &&
2578  !CB_LABEL (v)->flag_declaratives) {
2579  if (!cb_relaxed_syntax_check) {
2580  cb_error_x (x, _("'%s' is not in DECLARATIVES"),
2581  CB_LABEL (v)->name);
2582  } else {
2583  cb_warning_x (x, _("'%s' is not in DECLARATIVES"),
2584  CB_LABEL (v)->name);
2585  }
2586  }
2587  if (CB_LABEL (v)->flag_declaratives &&
2588  !CB_REFERENCE (x)->flag_in_decl &&
2589  !CB_REFERENCE (x)->flag_decl_ok) {
2590  cb_error_x (x, _("Invalid reference to '%s' (In DECLARATIVES)"), CB_LABEL (v)->name);
2591  }
2592  CB_LABEL (v)->flag_begin = 1;
2593  if (CB_REFERENCE (x)->length) {
2594  CB_LABEL (v)->flag_return = 1;
2595  }
2596  } else if (v != cb_error_node) {
2597  cb_error_x (x, _("'%s' not a procedure name"), cb_name (x));
2598  }
2599  }
2600 
2601  /* Resolve DEBUG references */
2602  /* For data items, we may need to adjust the size of DEBUG-CONTENTS */
2603  /* Basic size of DEBUG-CONTENTS is 31 */
2604  size = 31;
2605  for (l = prog->debug_list; l; l = CB_CHAIN (l)) {
2606  x = CB_VALUE (l);
2607  current_section = CB_REFERENCE (x)->section;
2608  current_paragraph = CB_REFERENCE (x)->paragraph;
2609  v = cb_ref (x);
2610  if (v == cb_error_node) {
2611  continue;
2612  }
2613  switch (CB_TREE_TAG (v)) {
2614  case CB_TAG_LABEL:
2615  if (current_program->all_procedure) {
2616  cb_error_x (x, _("'%s' - DEBUGGING target invalid with ALL PROCEDURES"),
2617  cb_name (x));
2618  }
2619  if (!CB_LABEL (v)->flag_real_label) {
2620  cb_error_x (x, _("'%s' - DEBUGGING target invalid"),
2621  cb_name (x));
2622  }
2623  CB_LABEL (v)->debug_section =
2624  CB_REFERENCE (x)->debug_section;
2625  CB_LABEL (v)->flag_debugging_mode = 1;
2626  break;
2627  case CB_TAG_FILE:
2628  break;
2629  case CB_TAG_FIELD:
2630  if (CB_FIELD (v)->size > size) {
2631  size = CB_FIELD (v)->size;
2632  }
2633  break;
2634  default:
2635  cb_error_x (x, _("'%s' is not a valid DEBUGGING target"),
2636  cb_name (x));
2637  break;
2638  }
2639  }
2640  /* If necessary, adjust size of DEBUG-CONTENTS (and DEBUG-ITEM) */
2641  if (current_program->flag_debugging) {
2642  if (size != 31) {
2643  f = CB_FIELD_PTR (cb_debug_contents);
2644  f->size = size;
2645  f->memory_size = size;
2646  size -= 31;
2647  f = CB_FIELD_PTR (cb_debug_item);
2648  f->size += size;
2649  f->memory_size += size;
2650  }
2651  }
2652 
2653  /* Build ALTER ids - We need to remove duplicates */
2654  for (l = prog->alter_list; l; l = CB_CHAIN (l)) {
2655  if (CB_PURPOSE (l) == cb_error_node) {
2656  continue;
2657  }
2658  if (CB_VALUE (l) == cb_error_node) {
2659  continue;
2660  }
2661  x = CB_PURPOSE (l);
2662  v = CB_VALUE (l);
2663  if (CB_REFERENCE (x)->value == cb_error_node) {
2664  continue;
2665  }
2666  if (CB_REFERENCE (v)->value == cb_error_node) {
2667  continue;
2668  }
2669  l1 = CB_LABEL (CB_REFERENCE (x)->value);
2670  l2 = CB_LABEL (CB_REFERENCE (v)->value);
2671  current_section = CB_REFERENCE (x)->section;
2672  current_paragraph = CB_REFERENCE (x)->paragraph;
2673  /* First statement in paragraph must be a GO TO */
2674  if (!l1->flag_first_is_goto) {
2675  cb_error_x (x, _("'%s' is not an alterable paragraph"),
2676  l1->name);
2677  continue;
2678  }
2679  for (aid = l1->alter_gotos; aid; aid = aid->next) {
2680  if (aid->goto_id == l2->id) {
2681  break;
2682  }
2683  }
2684  if (!aid) {
2685  aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
2686  aid->next = l1->alter_gotos;
2687  aid->goto_id = l2->id;
2688  l1->alter_gotos = aid;
2689  }
2690  for (aid = prog->alter_gotos; aid; aid = aid->next) {
2691  if (aid->goto_id == l1->id) {
2692  break;
2693  }
2694  }
2695  if (!aid) {
2696  aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
2697  aid->next = prog->alter_gotos;
2698  aid->goto_id = l1->id;
2699  prog->alter_gotos = aid;
2700  }
2701  }
2702 
2703  current_section = save_section;
2704  current_paragraph = save_paragraph;
2705  cobc_cs_check = 0;
2706 
2707  prog->file_list = cb_list_reverse (prog->file_list);
2708  prog->exec_list = cb_list_reverse (prog->exec_list);
2709 }
2710 
2711 /* Expressions */
2712 
2713 static void
2714 cb_expr_init (void)
2715 {
2716  if (initialized == 0) {
2717  initialized = 1;
2718  /* Init stack */
2719  expr_stack_size = START_STACK_SIZE;
2720  expr_stack = cobc_main_malloc (sizeof (struct expr_node) * START_STACK_SIZE);
2721  } else {
2722  memset (expr_stack, 0, expr_stack_size * sizeof (struct expr_node));
2723  }
2724  expr_op = 0;
2725  expr_lh = NULL;
2726  /* First three entries are dummies */
2727  expr_index = 3;
2728 }
2729 
2730 static int
2731 expr_chk_cond (cb_tree expr_1, cb_tree expr_2)
2732 {
2733  struct cb_field *f1;
2734  struct cb_field *f2;
2735  int is_ptr_1;
2736  int is_ptr_2;
2737 
2738  /* 88 level is invalid here */
2739  /* Likewise combination of pointer and non-pointer */
2740  is_ptr_1 = 0;
2741  is_ptr_2 = 0;
2742  if (CB_REF_OR_FIELD_P (expr_1)) {
2743  f1 = CB_FIELD_PTR (expr_1);
2744  if (f1->level == 88) {
2745  return 1;
2746  }
2747  if (f1->flag_is_pointer) {
2748  is_ptr_1 = 1;
2749  }
2750  } else if (CB_CAST_P (expr_1)) {
2751  switch (CB_CAST (expr_1)->cast_type) {
2752  case CB_CAST_ADDRESS:
2753  case CB_CAST_ADDR_OF_ADDR:
2754  case CB_CAST_PROGRAM_POINTER:
2755  is_ptr_1 = 1;
2756  break;
2757  default:
2758  break;
2759  }
2760  } else if (expr_1 == cb_null) {
2761  is_ptr_1 = 1;
2762  }
2763  if (CB_REF_OR_FIELD_P (expr_2)) {
2764  f2 = CB_FIELD_PTR (expr_2);
2765  if (f2->level == 88) {
2766  return 1;
2767  }
2768  if (f2->flag_is_pointer) {
2769  is_ptr_2 = 1;
2770  }
2771  } else if (CB_CAST_P (expr_2)) {
2772  switch (CB_CAST (expr_2)->cast_type) {
2773  case CB_CAST_ADDRESS:
2774  case CB_CAST_ADDR_OF_ADDR:
2775  case CB_CAST_PROGRAM_POINTER:
2776  is_ptr_2 = 1;
2777  break;
2778  default:
2779  break;
2780  }
2781  } else if (expr_2 == cb_null) {
2782  is_ptr_2 = 1;
2783  }
2784  return is_ptr_1 ^ is_ptr_2;
2785 }
2786 
2787 static int
2788 expr_reduce (int token)
2789 {
2790  /* Example:
2791  * index: -3 -2 -1 0
2792  * token: 'x' '*' 'x' '+' ...
2793  */
2794 
2795  int op;
2796 
2797  while (expr_prio[TOKEN (-2)] <= expr_prio[token]) {
2798  /* Reduce the expression depending on the last operator */
2799  op = TOKEN (-2);
2800  switch (op) {
2801  case 'x':
2802  return 0;
2803 
2804  case '+':
2805  case '-':
2806  case '*':
2807  case '/':
2808  case '^':
2809  /* Arithmetic operators: 'x' op 'x' */
2810  if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
2811  return -1;
2812  }
2813  TOKEN (-3) = 'x';
2814  VALUE (-3) = cb_build_binary_op (VALUE (-3), op, VALUE (-1));
2815  expr_index -= 2;
2816  break;
2817 
2818  case '!':
2819  /* Negation: '!' 'x' */
2820  if (TOKEN (-1) != 'x') {
2821  return -1;
2822  }
2823  /* 'x' '=' 'x' '|' '!' 'x' */
2824  if (expr_lh) {
2825  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2826  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2827  }
2828  }
2829  TOKEN (-2) = 'x';
2830  VALUE (-2) = CB_BUILD_NEGATION (VALUE (-1));
2831  expr_index -= 1;
2832  break;
2833 
2834  case '&':
2835  case '|':
2836  /* Logical AND/OR: 'x' op 'x' */
2837  if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
2838  return -1;
2839  }
2840  /* 'x' '=' 'x' '|' 'x' */
2841  if (expr_lh) {
2842  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2843  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2844  }
2845  if (CB_TREE_CLASS (VALUE (-3)) != CB_CLASS_BOOLEAN) {
2846  VALUE (-3) = cb_build_binary_op (expr_lh, expr_op, VALUE (-3));
2847  }
2848  }
2849  /* Warning for complex expressions without explicit parentheses
2850  (i.e., "a OR b AND c" or "a AND b OR c") */
2851  if (cb_warn_parentheses && op == '|') {
2852  if ((CB_BINARY_OP_P (VALUE (-3)) &&
2853  CB_BINARY_OP (VALUE (-3))->op == '&') ||
2854  (CB_BINARY_OP_P (VALUE (-1)) &&
2855  CB_BINARY_OP (VALUE (-1))->op == '&')) {
2856  cb_warning (_("Suggest parentheses around AND within OR"));
2857  }
2858  }
2859  TOKEN (-3) = 'x';
2860  VALUE (-3) = cb_build_binary_op (VALUE (-3), op,
2861  VALUE (-1));
2862  expr_index -= 2;
2863  break;
2864 
2865  case '(':
2866  case ')':
2867  return 0;
2868 
2869  default:
2870  /* Relational operators */
2871  if (TOKEN (-1) != 'x') {
2872  return -1;
2873  }
2874  switch (TOKEN (-3)) {
2875  case 'x':
2876  /* Simple condition: 'x' op 'x' */
2877  if (VALUE (-3) == cb_error_node ||
2878  VALUE (-1) == cb_error_node) {
2879  VALUE (-3) = cb_error_node;
2880  } else {
2881  expr_lh = VALUE (-3);
2882  if (expr_chk_cond (expr_lh, VALUE (-1))) {
2883  VALUE (-3) = cb_error_node;
2884  return 1;
2885  }
2886  expr_op = op;
2887  TOKEN (-3) = 'x';
2888  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2889  VALUE (-3) = cb_build_binary_op (expr_lh, op, VALUE (-1));
2890  } else {
2891  VALUE (-3) = VALUE (-1);
2892  }
2893  }
2894  expr_index -= 2;
2895  break;
2896  case '&':
2897  case '|':
2898  /* Complex condition: 'x' '=' 'x' '|' op 'x' */
2899  if (VALUE (-1) == cb_error_node) {
2900  VALUE (-2) = cb_error_node;
2901  } else {
2902  expr_op = op;
2903  TOKEN (-2) = 'x';
2904  if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN && expr_lh) {
2905  VALUE (-2) = cb_build_binary_op (expr_lh, op, VALUE (-1));
2906  } else {
2907  VALUE (-2) = VALUE (-1);
2908  }
2909  }
2910  expr_index -= 1;
2911  break;
2912  default:
2913  return -1;
2914  }
2915  break;
2916  }
2917  }
2918 
2919  /* Handle special case "op OR x AND" */
2920  if (token == '&' && TOKEN (-2) == '|' &&
2921  CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
2922  TOKEN (-1) = 'x';
2923  VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
2924  }
2925 
2926  return 0;
2927 }
2928 
2929 static void
2930 cb_expr_shift_sign (const int op)
2931 {
2932  int have_not;
2933 
2934  if (TOKEN (-1) == '!') {
2935  have_not = 1;
2936  expr_index--;
2937  } else {
2938  have_not = 0;
2939  }
2940  (void)expr_reduce ('=');
2941  if (TOKEN (-1) == 'x') {
2942  VALUE (-1) = cb_build_binary_op (VALUE (-1), op, cb_zero);
2943  if (have_not) {
2944  VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
2945  }
2946  }
2947 }
2948 
2949 static void
2950 cb_expr_shift_class (const char *name)
2951 {
2952  int have_not;
2953 
2954  if (TOKEN (-1) == '!') {
2955  have_not = 1;
2956  expr_index--;
2957  } else {
2958  have_not = 0;
2959  }
2960  (void)expr_reduce ('=');
2961  if (TOKEN (-1) == 'x') {
2962  VALUE (-1) = CB_BUILD_FUNCALL_1 (name, VALUE (-1));
2963  if (have_not) {
2964  VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
2965  }
2966  }
2967 }
2968 
2969 static void
2970 cb_expr_shift (int token, cb_tree value)
2971 {
2972  switch (token) {
2973  case 'M':
2974  break;
2975  case 'x':
2976  /* Sign ZERO condition */
2977  if (value == cb_zero) {
2978  if (TOKEN (-1) == 'x' || TOKEN (-1) == '!') {
2979  cb_expr_shift_sign ('=');
2980  return;
2981  }
2982  }
2983 
2984  /* Unary sign */
2985  if ((TOKEN (-1) == '+' || TOKEN (-1) == '-') &&
2986  TOKEN (-2) != 'x') {
2987  if (TOKEN (-1) == '-') {
2988  value = cb_build_binary_op (cb_zero, '-', value);
2989  }
2990  expr_index -= 1;
2991  }
2992  break;
2993 
2994  case '(':
2995  /* 'x' op '(' --> '(' 'x' op */
2996  switch (TOKEN (-1)) {
2997  case '=':
2998  case '~':
2999  case '<':
3000  case '>':
3001  case '[':
3002  case ']':
3003  expr_op = TOKEN (-1);
3004  if (TOKEN (-2) == 'x') {
3005  expr_lh = VALUE (-2);
3006  }
3007  break;
3008  default:
3009  break;
3010  }
3011  break;
3012 
3013  case ')':
3014  /* Enclosed by parentheses */
3015  (void)expr_reduce (token);
3016  if (TOKEN (-2) == '(') {
3017  value = CB_BUILD_PARENTHESIS (VALUE (-1));
3018  expr_index -= 2;
3019  cb_expr_shift ('x', value);
3020  return;
3021  }
3022  break;
3023 
3024  default:
3025  /* '<' '|' '=' --> '[' */
3026  /* '>' '|' '=' --> ']' */
3027  if (token == '=' && TOKEN (-1) == '|' &&
3028  (TOKEN (-2) == '<' || TOKEN (-2) == '>')) {
3029  token = (TOKEN (-2) == '<') ? '[' : ']';
3030  expr_index -= 2;
3031  }
3032 
3033  /* '!' '=' --> '~', etc. */
3034  if (TOKEN (-1) == '!') {
3035  switch (token) {
3036  case '=':
3037  token = '~';
3038  expr_index--;
3039  break;
3040  case '~':
3041  token = '=';
3042  expr_index--;
3043  break;
3044  case '<':
3045  token = ']';
3046  expr_index--;
3047  break;
3048  case '>':
3049  token = '[';
3050  expr_index--;
3051  break;
3052  case '[':
3053  token = '>';
3054  expr_index--;
3055  break;
3056  case ']':
3057  token = '<';
3058  expr_index--;
3059  break;
3060  default:
3061  break;
3062  }
3063  }
3064  break;
3065  }
3066 
3067  /* Reduce */
3068  /* Catch invalid condition */
3069  if (expr_reduce (token) > 0) {
3070  return;
3071  }
3072 
3073  /* Allocate sufficient stack memory */
3074  if (expr_index >= expr_stack_size) {
3075  while (expr_stack_size <= expr_index) {
3076  expr_stack_size *= 2;
3077  }
3078  expr_stack = cobc_main_realloc (expr_stack, sizeof (struct expr_node) * expr_stack_size);
3079  }
3080 
3081  /* Put on the stack */
3082  TOKEN (0) = token;
3083  VALUE (0) = value;
3084  expr_index++;
3085 }
3086 
3087 static void
3088 expr_expand (cb_tree *x)
3089 {
3090  struct cb_binary_op *p;
3091 
3092 start:
3093  /* Remove parenthesis */
3094  if (CB_BINARY_OP_P (*x)) {
3095  p = CB_BINARY_OP (*x);
3096  if (p->op == '@') {
3097  *x = p->x;
3098  goto start;
3099  }
3100  expr_expand (&p->x);
3101  if (p->y) {
3102  expr_expand (&p->y);
3103  }
3104  }
3105 }
3106 
3107 static cb_tree
3108 cb_expr_finish (void)
3109 {
3110  /* Reduce all */
3111  (void)expr_reduce (0);
3112 
3113  if (!expr_stack[3].value) {
3114  cb_error (_("Invalid expression"));
3115  return cb_error_node;
3116  }
3117 
3118  expr_stack[3].value->source_file = cb_source_file;
3119  expr_stack[3].value->source_line = cb_exp_line;
3120 
3121  if (expr_index != 4) {
3122  cb_error_x (expr_stack[3].value, _("Invalid expression"));
3123  return cb_error_node;
3124  }
3125 
3126  expr_expand (&expr_stack[3].value);
3127  if (expr_stack[3].token != 'x') {
3128  cb_error_x (expr_stack[3].value, _("Invalid expression"));
3129  return cb_error_node;
3130  }
3131 
3132  return expr_stack[3].value;
3133 }
3134 
3135 cb_tree
3136 cb_build_expr (cb_tree list)
3137 {
3138  cb_tree l;
3139  int op;
3140 
3141  cb_expr_init ();
3142 
3143  for (l = list; l; l = CB_CHAIN (l)) {
3144  op = CB_PURPOSE_INT (l);
3145  switch (op) {
3146  case '9':
3147  /* NUMERIC */
3148  cb_expr_shift_class ("cob_is_numeric");
3149  break;
3150  case 'A':
3151  /* ALPHABETIC */
3152  cb_expr_shift_class ("cob_is_alpha");
3153  break;
3154  case 'L':
3155  /* ALPHABETIC_LOWER */
3156  cb_expr_shift_class ("cob_is_lower");
3157  break;
3158  case 'U':
3159  /* ALPHABETIC_UPPER */
3160  cb_expr_shift_class ("cob_is_upper");
3161  break;
3162  case 'P':
3163  /* POSITIVE */
3164  cb_expr_shift_sign ('>');
3165  break;
3166  case 'N':
3167  /* NEGATIVE */
3168  cb_expr_shift_sign ('<');
3169  break;
3170  case 'O':
3171  /* OMITTED */
3172  if (current_statement) {
3173  current_statement->null_check = NULL;
3174  }
3175  cb_expr_shift_class ("cob_is_omitted");
3176  break;
3177  case 'C':
3178  /* CLASS */
3179  cb_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname);
3180  break;
3181  default:
3182  cb_expr_shift (op, CB_VALUE (l));
3183  break;
3184  }
3185  }
3186 
3187  return cb_expr_finish ();
3188 }
3189 
3190 /* Numerical operation */
3191 
3192 static cb_tree
3193 build_store_option (cb_tree x, cb_tree round_opt)
3194 {
3195  struct cb_field *f;
3196  int opt;
3197  enum cb_usage usage;
3198 
3199  f = CB_FIELD_PTR (x);
3200  usage = f->usage;
3201 #if 0 /* RXWRXW - FP */
3202  if (usage == CB_USAGE_DOUBLE || usage == CB_USAGE_FLOAT) {
3203  /* Rounding on FP is useless */
3204  opt = 0;
3205  } else {
3206 #endif
3207  opt = CB_INTEGER (round_opt)->val;
3208 #if 0 /* RXWRXW - FP */
3209  }
3210 #endif
3211 
3212  if (usage == CB_USAGE_COMP_5 || usage == CB_USAGE_COMP_X) {
3213  /* Do not check NOT ERROR case, so that we optimize */
3214  if (current_statement->handler1) {
3215  opt |= COB_STORE_KEEP_ON_OVERFLOW;
3216  }
3217  } else if (current_statement->handler_id) {
3218  /* There is a [NOT] ERROR/OVERFLOW/EXCEPTION - Set in parser */
3219  opt |= COB_STORE_KEEP_ON_OVERFLOW;
3220  } else if (usage == CB_USAGE_BINARY && cb_binary_truncate) {
3221  /* Truncate binary field to digits in picture */
3222  opt |= COB_STORE_TRUNC_ON_OVERFLOW;
3223  }
3224 
3225  return cb_int (opt);
3226 }
3227 
3228 static cb_tree
3229 decimal_alloc (void)
3230 {
3231  cb_tree x;
3232 
3233  x = cb_build_decimal (current_program->decimal_index);
3234  current_program->decimal_index++;
3235  if (current_program->decimal_index >= COB_MAX_DEC_STRUCT) {
3236  cobc_abort_pr (_("Internal decimal structure size exceeded - %d"),
3237  COB_MAX_DEC_STRUCT);
3238  if (strcmp(current_statement->name, "COMPUTE") == 0) {
3239  cobc_abort_pr (_("Try to minimize the number of parenthesis "
3240  "or split into multiple computations."));
3241  }
3242  COBC_ABORT ();
3243  }
3244  if (current_program->decimal_index > current_program->decimal_index_max) {
3245  current_program->decimal_index_max = current_program->decimal_index;
3246  }
3247  return x;
3248 }
3249 
3250 static void
3251 decimal_free (void)
3252 {
3253  current_program->decimal_index--;
3254 }
3255 
3256 static void
3257 decimal_compute (const int op, cb_tree x, cb_tree y)
3258 {
3259  const char *func;
3260 
3261  switch (op) {
3262  case '+':
3263  func = "cob_decimal_add";
3264  break;
3265  case '-':
3266  func = "cob_decimal_sub";
3267  break;
3268  case '*':
3269  func = "cob_decimal_mul";
3270  break;
3271  case '/':
3272  func = "cob_decimal_div";
3273  break;
3274  case '^':
3275  func = "cob_decimal_pow";
3276  break;
3277  default:
3278  cobc_abort_pr (_("Unexpected operation %d"), op);
3279  COBC_ABORT ();
3280  }
3281  dpush (CB_BUILD_FUNCALL_2 (func, x, y));
3282 }
3283 
3284 static void
3285 decimal_expand (cb_tree d, cb_tree x)
3286 {
3287  struct cb_literal *l;
3288  struct cb_field *f;
3289  struct cb_binary_op *p;
3290  cb_tree t;
3291 
3292  switch (CB_TREE_TAG (x)) {
3293  case CB_TAG_CONST:
3294  if (x == cb_zero) {
3295  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
3296  cb_int0));
3297  } else {
3298  cobc_abort_pr (_("Unexpected constant expansion"));
3299  COBC_ABORT ();
3300  }
3301  break;
3302  case CB_TAG_LITERAL:
3303  /* Set d, N */
3304  l = CB_LITERAL (x);
3305  if (l->size < 19 && l->scale == 0) {
3306  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
3307  cb_build_cast_llint (x)));
3308  } else {
3309  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3310  }
3311  break;
3312  case CB_TAG_REFERENCE:
3313  /* Set d, X */
3314  f = CB_FIELD_PTR (x);
3315  /* Check numeric */
3316  if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
3317  cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
3318  }
3319  if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
3320  if (f->usage == CB_USAGE_DISPLAY ||
3321  f->usage == CB_USAGE_PACKED ||
3322  f->usage == CB_USAGE_COMP_6) {
3323  dpush (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
3324  x, CB_BUILD_STRING0 (f->name)));
3325  }
3326  }
3327 
3328  if ((f->usage == CB_USAGE_BINARY ||
3329  f->usage == CB_USAGE_COMP_5 ||
3330  f->usage == CB_USAGE_INDEX ||
3331  f->usage == CB_USAGE_COMP_X) &&
3332  !f->pic->scale &&
3333  (f->size == 1 || f->size == 2 || f->size == 4 ||
3334  f->size == 8)) {
3335  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d, cb_build_cast_llint (x)));
3336  } else {
3337  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3338  }
3339  break;
3340  case CB_TAG_BINARY_OP:
3341  /* Set d, X
3342  * Set t, Y
3343  * OP d, t */
3344  p = CB_BINARY_OP (x);
3345  decimal_expand (d, p->x);
3346  t = decimal_alloc ();
3347  decimal_expand (t, p->y);
3348  decimal_compute (p->op, d, t);
3349  decimal_free ();
3350  break;
3351  case CB_TAG_INTRINSIC:
3352  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
3353  break;
3354  default:
3355  cobc_abort_pr (_("Unexpected tree tag %d"), (int)CB_TREE_TAG (x));
3356  COBC_ABORT ();
3357  }
3358 }
3359 
3360 static void
3361 decimal_assign (cb_tree x, cb_tree d, cb_tree round_opt)
3362 {
3363  dpush (CB_BUILD_FUNCALL_3 ("cob_decimal_get_field", d, x,
3364  build_store_option (x, round_opt)));
3365 }
3366 
3367 static cb_tree
3368 cb_build_mul (cb_tree v, cb_tree n, cb_tree round_opt)
3369 {
3370  cb_tree opt;
3371  struct cb_field *f;
3372 
3373  if (CB_INDEX_P (v)) {
3374  return cb_build_move (cb_build_binary_op (v, '*', n), v);
3375  }
3376 
3377  if (CB_REF_OR_FIELD_P (v)) {
3378  f = CB_FIELD_PTR (v);
3379  f->count++;
3380  }
3381  if (CB_REF_OR_FIELD_P (n)) {
3382  f = CB_FIELD_PTR (n);
3383  f->count++;
3384  }
3385  opt = build_store_option (v, round_opt);
3386  return CB_BUILD_FUNCALL_3 ("cob_mul", v, n, opt);
3387 }
3388 
3389 static cb_tree
3390 cb_build_div (cb_tree v, cb_tree n, cb_tree round_opt)
3391 {
3392  cb_tree opt;
3393  struct cb_field *f;
3394 
3395  if (CB_INDEX_P (v)) {
3396  return cb_build_move (cb_build_binary_op (v, '/', n), v);
3397  }
3398 
3399  if (CB_REF_OR_FIELD_P (v)) {
3400  f = CB_FIELD_PTR (v);
3401  f->count++;
3402  }
3403  if (CB_REF_OR_FIELD_P (n)) {
3404  f = CB_FIELD_PTR (n);
3405  f->count++;
3406  }
3407  opt = build_store_option (v, round_opt);
3408  return CB_BUILD_FUNCALL_3 ("cob_div", v, n, opt);
3409 }
3410 
3411 static cb_tree
3412 build_decimal_assign (cb_tree vars, const int op, cb_tree val)
3413 {
3414  cb_tree l;
3415  cb_tree t;
3416  cb_tree s1;
3417  cb_tree s2;
3418  cb_tree d;
3419 
3420  d = decimal_alloc ();
3421 
3422  /* Set d, VAL */
3423  decimal_expand (d, val);
3424 
3425  s1 = NULL;
3426  if (op == 0) {
3427  for (l = vars; l; l = CB_CHAIN (l)) {
3428  /* Set VAR, d */
3429  decimal_assign (CB_VALUE (l), d, CB_PURPOSE (l));
3430  s2 = cb_list_reverse (decimal_stack);
3431  if (!s1) {
3432  s1 = s2;
3433  } else {
3434  s1 = cb_list_append (s1, s2);
3435  }
3436  decimal_stack = NULL;
3437  }
3438  } else {
3439  t = decimal_alloc ();
3440  for (l = vars; l; l = CB_CHAIN (l)) {
3441  /* Set t, VAR
3442  * OP t, d
3443  * set VAR, t
3444  */
3445  decimal_expand (t, CB_VALUE (l));
3446  decimal_compute (op, t, d);
3447  decimal_assign (CB_VALUE (l), t, CB_PURPOSE (l));
3448  s2 = cb_list_reverse (decimal_stack);
3449  if (!s1) {
3450  s1 = s2;
3451  } else {
3452  s1 = cb_list_append (s1, s2);
3453  }
3454  decimal_stack = NULL;
3455  }
3456  decimal_free ();
3457  }
3458 
3459  decimal_free ();
3460 
3461  return s1;
3462 }
3463 
3464 void
3465 cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val)
3466 {
3467  cb_tree l;
3468  cb_tree x;
3469 
3470  x = cb_check_numeric_value (val);
3471 
3472  if (op) {
3473  cb_list_map (cb_check_numeric_name, vars);
3474  } else {
3475  cb_list_map (cb_check_numeric_edited_name, vars);
3476  }
3477 
3478  if (cb_validate_one (x)) {
3479  return;
3480  }
3481  if (cb_validate_list (vars)) {
3482  return;
3483  }
3484 
3485  if (!CB_BINARY_OP_P (x)) {
3486  if (op == '+' || op == '-' || op == '*' || op == '/') {
3487  cb_check_data_incompat (x);
3488  for (l = vars; l; l = CB_CHAIN (l)) {
3489  cb_check_data_incompat (CB_VALUE (l));
3490  switch (op) {
3491  case '+':
3492  CB_VALUE (l) = cb_build_add (CB_VALUE (l), x, CB_PURPOSE (l));
3493  break;
3494  case '-':
3495  CB_VALUE (l) = cb_build_sub (CB_VALUE (l), x, CB_PURPOSE (l));
3496  break;
3497  case '*':
3498  CB_VALUE (l) = cb_build_mul (CB_VALUE (l), x, CB_PURPOSE (l));
3499  break;
3500  case '/':
3501  CB_VALUE (l) = cb_build_div (CB_VALUE (l), x, CB_PURPOSE (l));
3502  break;
3503  }
3504  }
3505  cb_emit_list (vars);
3506  return;
3507  }
3508  }
3509  if (x == cb_error_node) {
3510  return;
3511  }
3512 
3513  cb_emit_list (build_decimal_assign (vars, op, x));
3514 }
3515 
3516 /* Condition */
3517 
3518 static cb_tree
3519 build_cond_88 (cb_tree x)
3520 {
3521  struct cb_field *f;
3522  cb_tree l;
3523  cb_tree t;
3524  cb_tree c1;
3525  cb_tree c2;
3526 
3527  f = CB_FIELD_PTR (x);
3528  /* Refer to parents data storage */
3529  if (!f->parent) {
3530  /* Field is invalid */
3531  return cb_error_node;
3532  }
3533  x = cb_build_field_reference (f->parent, x);
3534  f->parent->count++;
3535  c1 = NULL;
3536 
3537  /* Build condition */
3538  for (l = f->values; l; l = CB_CHAIN (l)) {
3539  t = CB_VALUE (l);
3540  if (CB_PAIR_P (t)) {
3541  /* VALUE THRU VALUE */
3542  c2 = cb_build_binary_op (cb_build_binary_op (CB_PAIR_X (t), '[', x),
3543  '&', cb_build_binary_op (x, '[', CB_PAIR_Y (t)));
3544  } else {
3545  /* VALUE */
3546  c2 = cb_build_binary_op (x, '=', t);
3547  }
3548  if (c1 == NULL) {
3549  c1 = c2;
3550  } else {
3551  c1 = cb_build_binary_op (c1, '|', c2);
3552  }
3553  }
3554  return c1;
3555 }
3556 
3557 static cb_tree
3558 cb_build_optim_cond (struct cb_binary_op *p)
3559 {
3560  struct cb_field *f;
3561  const char *s;
3562  size_t n;
3563 
3564 #if 0 /* RXWRXW - US */
3565  struct cb_field *fy;
3566  if (CB_REF_OR_FIELD_P (p->y)) {
3567  fy = CB_FIELD_PTR (p->y);
3568  if (!fy->pic->have_sign && (fy->usage == CB_USAGE_BINARY ||
3569  fy->usage == CB_USAGE_COMP_5 ||
3570  fy->usage == CB_USAGE_COMP_X)) {
3571  return CB_BUILD_FUNCALL_2 ("cob_cmp_uint", p->x,
3572  cb_build_cast_int (p->y));
3573  }
3574  }
3575 #endif
3576 
3577  if (!CB_REF_OR_FIELD_P (p->x)) {
3578  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3579  cb_build_cast_llint (p->y));
3580  }
3581 
3582  f = CB_FIELD_PTR (p->x);
3583 #if 0 /* RXWRXW - SI */
3584  if (f->special_index) {
3585  return CB_BUILD_FUNCALL_2 ("cob_cmp_special",
3586  cb_build_cast_int (p->x),
3587  cb_build_cast_int (p->y));
3588  }
3589 #endif
3590  if (f->pic->scale || f->flag_any_numeric) {
3591  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3592  cb_build_cast_llint (p->y));
3593  }
3594  if (f->usage == CB_USAGE_PACKED) {
3595  if (f->pic->digits < 19) {
3596  optimize_defs[COB_CMP_PACKED_INT] = 1;
3597  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed_int",
3598  p->x,
3599  cb_build_cast_llint (p->y));
3600  } else {
3601  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
3602  p->x,
3603  cb_build_cast_llint (p->y));
3604  }
3605  }
3606  if (f->usage == CB_USAGE_COMP_6) {
3607  return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
3608  p->x,
3609  cb_build_cast_llint (p->y));
3610  }
3611  if (f->usage == CB_USAGE_DISPLAY &&
3612  !f->flag_sign_leading && !f->flag_sign_separate) {
3613  if (cb_fits_long_long (p->x)) {
3614  return CB_BUILD_FUNCALL_4 ("cob_cmp_numdisp",
3615  CB_BUILD_CAST_ADDRESS (p->x),
3616  cb_int (f->size),
3617  cb_build_cast_llint (p->y),
3618  cb_int (f->pic->have_sign ? 1 : 0));
3619  }
3620  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3621  cb_build_cast_llint (p->y));
3622  }
3623  if (f->usage == CB_USAGE_BINARY ||
3624  f->usage == CB_USAGE_COMP_5 ||
3625  f->usage == CB_USAGE_INDEX ||
3626  f->usage == CB_USAGE_COMP_X) {
3627  n = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3628  (16 * (f->flag_binary_swap ? 1 : 0));
3629 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3630  switch (f->size) {
3631  case 2:
3632 #ifdef COB_SHORT_BORK
3633  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3634  s = bin_compare_funcs[n].optim_name;
3635  break;
3636 #endif
3637  case 4:
3638  case 8:
3639  if (f->storage != CB_STORAGE_LINKAGE &&
3640  f->indexes == 0 && (f->offset % f->size) == 0) {
3641  optimize_defs[align_bin_compare_funcs[n].optim_val] = 1;
3642  s = align_bin_compare_funcs[n].optim_name;
3643  } else {
3644  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3645  s = bin_compare_funcs[n].optim_name;
3646  }
3647  break;
3648  default:
3649  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3650  s = bin_compare_funcs[n].optim_name;
3651  break;
3652  }
3653 #else
3654  optimize_defs[bin_compare_funcs[n].optim_val] = 1;
3655  s = bin_compare_funcs[n].optim_name;
3656 #endif
3657  if (s) {
3658  return CB_BUILD_FUNCALL_2 (s,
3659  CB_BUILD_CAST_ADDRESS (p->x),
3660  cb_build_cast_llint (p->y));
3661  }
3662  }
3663  return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
3664  cb_build_cast_llint (p->y));
3665 }
3666 
3667 static int
3668 cb_chk_num_cond (cb_tree x, cb_tree y)
3669 {
3670  struct cb_field *fx;
3671  struct cb_field *fy;
3672 
3673  if (!CB_REF_OR_FIELD_P (x)) {
3674  return 0;
3675  }
3676  if (!CB_REF_OR_FIELD_P (y)) {
3677  return 0;
3678  }
3679  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
3680  return 0;
3681  }
3682  if (CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC) {
3683  return 0;
3684  }
3685  if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
3686  return 0;
3687  }
3688  if (CB_TREE_CLASS (y) != CB_CLASS_NUMERIC) {
3689  return 0;
3690  }
3691  fx = CB_FIELD_PTR (x);
3692  fy = CB_FIELD_PTR (y);
3693  if (fx->usage != CB_USAGE_DISPLAY) {
3694  return 0;
3695  }
3696  if (fy->usage != CB_USAGE_DISPLAY) {
3697  return 0;
3698  }
3699  if (fx->pic->have_sign || fy->pic->have_sign) {
3700  return 0;
3701  }
3702  if (fx->size != fy->size) {
3703  return 0;
3704  }
3705  if (fx->pic->scale != fy->pic->scale) {
3706  return 0;
3707  }
3708  return 1;
3709 }
3710 
3711 static int
3712 cb_chk_alpha_cond (cb_tree x)
3713 {
3714  if (current_program->alphabet_name_list) {
3715  return 0;
3716  }
3717  if (CB_LITERAL_P (x)) {
3718  return 1;
3719  }
3720  if (!CB_REF_OR_FIELD_P (x)) {
3721  return 0;
3722  }
3723  if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC &&
3724  CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHABETIC) {
3725  return 0;
3726  }
3727  if (cb_field_variable_size (CB_FIELD_PTR (x))) {
3728  return 0;
3729  }
3730  if (cb_field_size (x) < 0) {
3731  return 0;
3732  }
3733  return 1;
3734 }
3735 
3736 cb_tree
3737 cb_build_cond (cb_tree x)
3738 {
3739  struct cb_field *f;
3740  struct cb_binary_op *p;
3741  cb_tree d1;
3742  cb_tree d2;
3743  int size1;
3744  int size2;
3745 
3746  if (x == cb_error_node) {
3747  return cb_error_node;
3748  }
3749  switch (CB_TREE_TAG (x)) {
3750  case CB_TAG_CONST:
3751  if (x != cb_any && x != cb_true && x != cb_false) {
3752  cb_error_x (CB_TREE(current_statement),
3753  _("Invalid expression"));
3754  return cb_error_node;
3755  }
3756  return x;
3757  case CB_TAG_FUNCALL:
3758  return x;
3759  case CB_TAG_REFERENCE:
3760  if (!CB_FIELD_P (cb_ref (x))) {
3761  return cb_build_cond (cb_ref (x));
3762  }
3763 
3764  f = CB_FIELD_PTR (x);
3765 
3766  /* Level 88 condition */
3767  if (f->level == 88) {
3768  /* Build an 88 condition at every occurrence */
3769  /* as it may be subscripted */
3770  return cb_build_cond (build_cond_88 (x));
3771  }
3772 
3773  break;
3774  case CB_TAG_BINARY_OP:
3775  p = CB_BINARY_OP (x);
3776  if (!p->x || p->x == cb_error_node) {
3777  return cb_error_node;
3778  }
3779  switch (p->op) {
3780  case '!':
3781  return CB_BUILD_NEGATION (cb_build_cond (p->x));
3782  case '&':
3783  case '|':
3784  if (!p->y || p->y == cb_error_node) {
3785  return cb_error_node;
3786  }
3787  return cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y));
3788  default:
3789  if (!p->y || p->y == cb_error_node) {
3790  return cb_error_node;
3791  }
3792  if (CB_INDEX_P (p->x) || CB_INDEX_P (p->y) ||
3793  CB_TREE_CLASS (p->x) == CB_CLASS_POINTER ||
3794  CB_TREE_CLASS (p->y) == CB_CLASS_POINTER) {
3795  x = cb_build_binary_op (p->x, '-', p->y);
3796  } else if (CB_BINARY_OP_P (p->x) ||
3797  CB_BINARY_OP_P (p->y)) {
3798  /* Decimal comparison */
3799  d1 = decimal_alloc ();
3800  d2 = decimal_alloc ();
3801 
3802  decimal_expand (d1, p->x);
3803  decimal_expand (d2, p->y);
3804  dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2));
3805  decimal_free ();
3806  decimal_free ();
3807  x = cb_list_reverse (decimal_stack);
3808  decimal_stack = NULL;
3809  } else {
3810  /* DEBUG Bypass optimization for PERFORM */
3811  if (current_program->flag_debugging) {
3812  x = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
3813  break;
3814  }
3815  if (cb_chk_num_cond (p->x, p->y)) {
3816  size1 = cb_field_size (p->x);
3817  x = CB_BUILD_FUNCALL_3 ("memcmp",
3818  CB_BUILD_CAST_ADDRESS (p->x),
3819  CB_BUILD_CAST_ADDRESS (p->y),
3820  cb_int (size1));
3821  break;
3822  }
3823  if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC &&
3824  CB_TREE_CLASS (p->y) == CB_CLASS_NUMERIC &&
3825  cb_fits_long_long (p->y)) {
3826  x = cb_build_optim_cond (p);
3827  break;
3828  }
3829 
3830  /* Field comparison */
3831  if ((CB_REF_OR_FIELD_P (p->x)) &&
3832  (CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHANUMERIC ||
3833  CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHABETIC) &&
3834  cb_field_size (p->x) == 1 &&
3835  !current_program->alphabet_name_list &&
3836  (p->y == cb_space || p->y == cb_low ||
3837  p->y == cb_high || p->y == cb_zero)) {
3838  x = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
3839  break;
3840  }
3841  if (cb_chk_alpha_cond (p->x) &&
3842  cb_chk_alpha_cond (p->y)) {
3843  size1 = cb_field_size (p->x);
3844  size2 = cb_field_size (p->y);
3845  } else {
3846  size1 = 0;
3847  size2 = 0;
3848  }
3849  if (size1 == 1 && size2 == 1) {
3850  x = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
3851  } else if (size1 != 0 && size1 == size2) {
3852  x = CB_BUILD_FUNCALL_3 ("memcmp",
3853  CB_BUILD_CAST_ADDRESS (p->x),
3854  CB_BUILD_CAST_ADDRESS (p->y),
3855  cb_int (size1));
3856  } else {
3857  if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC && p->y == cb_zero) {
3858  x = cb_build_optim_cond (p);
3859  } else {
3860  x = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
3861  }
3862  }
3863  }
3864  }
3865  return cb_build_binary_op (x, p->op, p->y);
3866  default:
3867  break;
3868  }
3869  cb_error_x (x, _("Invalid expression"));
3870  return cb_error_node;
3871 }
3872 
3873 /* ADD/SUBTRACT CORRESPONDING */
3874 
3875 static cb_tree
3876 cb_build_optim_add (cb_tree v, cb_tree n)
3877 {
3878  size_t z;
3879  const char *s;
3880  struct cb_field *f;
3881 
3882  if (CB_REF_OR_FIELD_P (v)) {
3883  f = CB_FIELD_PTR (v);
3884  if (!f->pic) {
3885  return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
3886  cb_build_cast_int (n),
3887  cb_int0);
3888  }
3889  if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
3890  f->usage == CB_USAGE_COMP_5 ||
3891  f->usage == CB_USAGE_COMP_X)) {
3892  z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3893  (16 * (f->flag_binary_swap ? 1 : 0));
3894 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3895  switch (f->size) {
3896  case 2:
3897 #ifdef COB_SHORT_BORK
3898  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3899  s = bin_add_funcs[z].optim_name;
3900  break;
3901 #endif
3902  case 4:
3903  case 8:
3904  if (f->storage != CB_STORAGE_LINKAGE &&
3905  f->indexes == 0 &&
3906  (f->offset % f->size) == 0) {
3907  optimize_defs[align_bin_add_funcs[z].optim_val] = 1;
3908  s = align_bin_add_funcs[z].optim_name;
3909  } else {
3910  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3911  s = bin_add_funcs[z].optim_name;
3912  }
3913  break;
3914  default:
3915  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3916  s = bin_add_funcs[z].optim_name;
3917  break;
3918  }
3919 #else
3920  if (f->usage == CB_USAGE_COMP_5) {
3921  switch (f->size) {
3922  case 1:
3923  case 2:
3924  case 4:
3925  case 8:
3926  return cb_build_assign (v, cb_build_binary_op (v, '+', n));
3927  default:
3928  break;
3929  }
3930  }
3931  optimize_defs[bin_add_funcs[z].optim_val] = 1;
3932  s = bin_add_funcs[z].optim_name;
3933 #endif
3934  if (s) {
3935  return CB_BUILD_FUNCALL_2 (s,
3936  CB_BUILD_CAST_ADDRESS (v),
3937  cb_build_cast_int (n));
3938  }
3939  } else if (!f->pic->scale && f->usage == CB_USAGE_PACKED &&
3940  f->pic->digits < 10) {
3941  optimize_defs[COB_ADD_PACKED_INT] = 1;
3942  return CB_BUILD_FUNCALL_2 ("cob_add_packed_int",
3943  v, cb_build_cast_int (n));
3944  }
3945  }
3946  return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
3947  cb_build_cast_int (n), cb_int0);
3948 }
3949 
3950 static cb_tree
3951 cb_build_optim_sub (cb_tree v, cb_tree n)
3952 {
3953  size_t z;
3954  const char *s;
3955  struct cb_field *f;
3956 
3957  if (CB_REF_OR_FIELD_P (v)) {
3958  f = CB_FIELD_PTR (v);
3959  if (!f->pic->scale && (f->usage == CB_USAGE_BINARY ||
3960  f->usage == CB_USAGE_COMP_5 ||
3961  f->usage == CB_USAGE_COMP_X)) {
3962  z = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0)) +
3963  (16 * (f->flag_binary_swap ? 1 : 0));
3964 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER)
3965  switch (f->size) {
3966  case 2:
3967 #ifdef COB_SHORT_BORK
3968  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3969  s = bin_sub_funcs[z].optim_name;
3970  break;
3971 #endif
3972  case 4:
3973  case 8:
3974  if (f->storage != CB_STORAGE_LINKAGE &&
3975  f->indexes == 0 && (f->offset % f->size) == 0) {
3976  optimize_defs[align_bin_sub_funcs[z].optim_val] = 1;
3977  s = align_bin_sub_funcs[z].optim_name;
3978  } else {
3979  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3980  s = bin_sub_funcs[z].optim_name;
3981  }
3982  break;
3983  default:
3984  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
3985  s = bin_sub_funcs[z].optim_name;
3986  break;
3987  }
3988 #else
3989  if (f->usage == CB_USAGE_COMP_5) {
3990  switch (f->size) {
3991  case 1:
3992  case 2:
3993  case 4:
3994  case 8:
3995  return cb_build_assign (v, cb_build_binary_op (v, '-', n));
3996  default:
3997  break;
3998  }
3999  }
4000  optimize_defs[bin_sub_funcs[z].optim_val] = 1;
4001  s = bin_sub_funcs[z].optim_name;
4002 #endif
4003  if (s) {
4004  return CB_BUILD_FUNCALL_2 (s,
4005  CB_BUILD_CAST_ADDRESS (v),
4006  cb_build_cast_int (n));
4007  }
4008  }
4009  }
4010  return CB_BUILD_FUNCALL_3 ("cob_sub_int", v,
4011  cb_build_cast_int (n), cb_int0);
4012 }
4013 
4014 cb_tree
4015 cb_build_add (cb_tree v, cb_tree n, cb_tree round_opt)
4016 {
4017  cb_tree opt;
4018  struct cb_field *f;
4019 
4020 #ifdef COB_NON_ALIGNED
4021  if (CB_INDEX_P (v)) {
4022  return cb_build_move (cb_build_binary_op (v, '+', n), v);
4023  }
4024  if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
4025  optimize_defs[COB_POINTER_MANIP] = 1;
4026  return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int0);
4027  }
4028 #else
4029  if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
4030  return cb_build_move (cb_build_binary_op (v, '+', n), v);
4031  }
4032 #endif
4033 
4034  if (CB_REF_OR_FIELD_P (v)) {
4035  f = CB_FIELD_PTR (v);
4036  f->count++;
4037  }
4038  if (CB_REF_OR_FIELD_P (n)) {
4039  f = CB_FIELD_PTR (n);
4040  f->count++;
4041  }
4042  if (round_opt == cb_high) {
4043  /* Short circuit from tree.c for perform */
4044  if (cb_fits_int (n)) {
4045  return cb_build_optim_add (v, n);
4046  } else {
4047  return CB_BUILD_FUNCALL_3 ("cob_add", v, n, cb_int0);
4048  }
4049  }
4050  opt = build_store_option (v, round_opt);
4051  if (opt == cb_int0 && cb_fits_int (n)) {
4052  return cb_build_optim_add (v, n);
4053  }
4054  return CB_BUILD_FUNCALL_3 ("cob_add", v, n, opt);
4055 }
4056 
4057 cb_tree
4058 cb_build_sub (cb_tree v, cb_tree n, cb_tree round_opt)
4059 {
4060  cb_tree opt;
4061  struct cb_field *f;
4062 
4063 #ifdef COB_NON_ALIGNED
4064  if (CB_INDEX_P (v)) {
4065  return cb_build_move (cb_build_binary_op (v, '-', n), v);
4066  }
4067  if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
4068  optimize_defs[COB_POINTER_MANIP] = 1;
4069  return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int1);
4070  }
4071 #else
4072  if (CB_INDEX_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
4073  return cb_build_move (cb_build_binary_op (v, '-', n), v);
4074  }
4075 #endif
4076 
4077  if (CB_REF_OR_FIELD_P (v)) {
4078  f = CB_FIELD_PTR (v);
4079  f->count++;
4080  }
4081  if (CB_REF_OR_FIELD_P (n)) {
4082  f = CB_FIELD_PTR (n);
4083  f->count++;
4084  }
4085  opt = build_store_option (v, round_opt);
4086  if (opt == cb_int0 && cb_fits_int (n)) {
4087  return cb_build_optim_sub (v, n);
4088  }
4089  return CB_BUILD_FUNCALL_3 ("cob_sub", v, n, opt);
4090 }
4091 
4092 static unsigned int
4093 emit_corresponding (cb_tree (*func) (cb_tree f1, cb_tree f2, cb_tree f3),
4094  cb_tree x1, cb_tree x2, cb_tree opt)
4095 {
4096  struct cb_field *f1, *f2;
4097  cb_tree t1;
4098  cb_tree t2;
4099  unsigned int found;
4100 
4101  found = 0;
4102  for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
4103  if (!f1->redefines && !f1->flag_occurs) {
4104  for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
4105  if (!f2->redefines && !f2->flag_occurs) {
4106  if (strcmp (f1->name, f2->name) == 0) {
4107  t1 = cb_build_field_reference (f1, x1);
4108  t2 = cb_build_field_reference (f2, x2);
4109  if (f1->children && f2->children) {
4110  found += emit_corresponding (func, t1, t2, opt);
4111  } else {
4112  found++;
4113  cb_emit (func (t1, t2, opt));
4114  }
4115  }
4116  }
4117  }
4118  }
4119  }
4120  return found;
4121 }
4122 
4123 void
4124 cb_emit_corresponding (cb_tree (*func) (cb_tree f1, cb_tree f2, cb_tree f3),
4125  cb_tree x1, cb_tree x2, cb_tree opt)
4126 {
4127  x1 = cb_check_group_name (x1);
4128  x2 = cb_check_group_name (x2);
4129 
4130  if (cb_validate_one (x1)) {
4131  return;
4132  }
4133  if (cb_validate_one (x2)) {
4134  return;
4135  }
4136 
4137  if (!emit_corresponding (func, x1, x2, opt)) {
4138  if (cb_warn_corresponding) {
4139  cb_warning_x (x2, _("No CORRESPONDING items found"));
4140  }
4141  }
4142 }
4143 
4144 static unsigned int
4145 emit_move_corresponding (cb_tree x1, cb_tree x2)
4146 {
4147  struct cb_field *f1, *f2;
4148  cb_tree t1;
4149  cb_tree t2;
4150  unsigned int found;
4151 
4152  found = 0;
4153  for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
4154  if (!f1->redefines && !f1->flag_occurs) {
4155  for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
4156  if (!f2->redefines && !f2->flag_occurs) {
4157  if (strcmp (f1->name, f2->name) == 0) {
4158  t1 = cb_build_field_reference (f1, x1);
4159  t2 = cb_build_field_reference (f2, x2);
4160  if (f1->children && f2->children) {
4161  found += emit_move_corresponding (t1, t2);
4162  } else {
4163  cb_emit (cb_build_move (t1, t2));
4164  found++;
4165  }
4166  }
4167  }
4168  }
4169  }
4170  }
4171  return found;
4172 }
4173 
4174 void
4175 cb_emit_move_corresponding (cb_tree x1, cb_tree x2)
4176 {
4177  cb_tree l;
4178  cb_tree v;
4179 
4180  x1 = cb_check_group_name (x1);
4181  if (cb_validate_one (x1)) {
4182  return;
4183  }
4184  for (l = x2; l; l = CB_CHAIN(l)) {
4185  v = CB_VALUE(l);
4186  v = cb_check_group_name (v);
4187  if (cb_validate_one (v)) {
4188  return;
4189  }
4190  if (!emit_move_corresponding (x1, v)) {
4191  if (cb_warn_corresponding) {
4192  cb_warning_x (v, _("No CORRESPONDING items found"));
4193  }
4194  }
4195  }
4196 }
4197 
4198 static void
4199 output_screen_from (struct cb_field *p, const unsigned int sisters)
4200 {
4201  int type;
4202 
4203  if (sisters && p->sister) {
4204  output_screen_from (p->sister, 1U);
4205  }
4206  if (p->children) {
4207  output_screen_from (p->children, 1U);
4208  }
4209 
4210  type = (p->children ? COB_SCREEN_TYPE_GROUP :
4211  p->values ? COB_SCREEN_TYPE_VALUE :
4212  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
4213  if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) {
4214  /* Bump reference count */
4215  p->count++;
4216  cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from,
4217  CB_TREE (p)));
4218  }
4219 }
4220 
4221 static void
4222 output_screen_to (struct cb_field *p, const unsigned int sisters)
4223 {
4224  int type;
4225 
4226  if (sisters && p->sister) {
4227  output_screen_to (p->sister, 1U);
4228  }
4229  if (p->children) {
4230  output_screen_to (p->children, 1U);
4231  }
4232 
4233  type = (p->children ? COB_SCREEN_TYPE_GROUP :
4234  p->values ? COB_SCREEN_TYPE_VALUE :
4235  (p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
4236  if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) {
4237  /* Bump reference count */
4238  p->count++;
4239  cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", CB_TREE (p), p->screen_to));
4240  }
4241 }
4242 
4243 /* ACCEPT statement */
4244 
4245 static COB_INLINE COB_A_INLINE int
4246 is_less_than_four_or_is_six (int x)
4247 {
4248  return x <= 4 || x == 6;
4249 }
4250 
4251 static COB_INLINE COB_A_INLINE int
4252 is_reference_with_value (cb_tree pos)
4253 {
4254  return CB_REFERENCE_P (pos)
4255  && (CB_REFERENCE (pos))->value != NULL;
4256 
4257 }
4258 
4259 static COB_INLINE COB_A_INLINE int
4260 value_is_numeric_field (cb_tree pos)
4261 {
4262  return CB_FIELD_P ((CB_REFERENCE (pos))->value)
4263  && (CB_REFERENCE (pos))->value->category == CB_CATEGORY_NUMERIC;
4264 
4265 }
4266 
4267 static COB_INLINE COB_A_INLINE int
4268 value_has_picture_clause (cb_tree pos)
4269 {
4270  return (CB_FIELD ((CB_REFERENCE (pos))->value))->pic != NULL;
4271 }
4272 
4273 static COB_INLINE COB_A_INLINE int
4274 value_pic_has_no_scale (cb_tree pos)
4275 {
4276  return (CB_FIELD ((CB_REFERENCE (pos))->value))->pic->scale == 0;
4277 }
4278 
4279 static int
4280 valid_screen_pos_type (cb_tree pos)
4281 {
4282  return is_reference_with_value (pos)
4283  && value_is_numeric_field (pos)
4284  && value_has_picture_clause (pos)
4285  && value_pic_has_no_scale (pos);
4286 }
4287 
4288 static int
4289 valid_screen_pos (cb_tree pos)
4290 {
4291  int size;
4292 
4293  /* Find size of pos value, if possible */
4294  if (CB_NUMERIC_LITERAL_P (pos)) {
4295  size = (CB_LITERAL (pos))->size;
4296  } else if (valid_screen_pos_type (pos)) {
4297  size = (CB_FIELD ((CB_REFERENCE (pos))->value))->pic->size;
4298  } else {
4299  cb_error (_("Invalid value in AT clause"));
4300  return 0;
4301  }
4302 
4303  /* Check if size is valid. If it isn't, display error. */
4304  if (size == 5) {
4305  cb_error (_("Value in AT clause may not have 5 digits"));
4306  return 0;
4307  } else if (size > 6) {
4308  cb_error (_("Value in AT clause may not be longer than 6 digits"));
4309  return 0;
4310  } else {
4311  return 1;
4312  }
4313 }
4314 
4315 static void
4316 cb_gen_field_accept (cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc,
4317  cb_tree scroll, cb_tree timeout, cb_tree prompt,
4318  cb_tree size_is, int dispattrs)
4319 {
4320  cb_tree line;
4321  cb_tree column;
4322 
4323  if (!pos) {
4324  cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
4325  var, NULL, NULL, fgc, bgc, scroll,
4326  timeout, prompt, size_is, cb_int (dispattrs)));
4327  } else if (CB_LIST_P (pos)) {
4328  line = CB_PAIR_X (pos);
4329  column = CB_PAIR_Y (pos);
4330  cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
4331  var, line, column, fgc, bgc, scroll,
4332  timeout, prompt, size_is, cb_int (dispattrs)));
4333  } else if (valid_screen_pos (pos)) {
4334  cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
4335  var, pos, NULL, fgc, bgc, scroll,
4336  timeout, prompt, size_is, cb_int (dispattrs)));
4337  }
4338 }
4339 
4340 void
4341 cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr)
4342 {
4343  cb_tree line;
4344  cb_tree column;
4345  cb_tree fgc;
4346  cb_tree bgc;
4347  cb_tree scroll;
4348  cb_tree timeout;
4349  cb_tree prompt;
4350  cb_tree size_is; /* WITH SIZE IS */
4351  int dispattrs;
4352 
4353  if (cb_validate_one (var)) {
4354  return;
4355  }
4356 
4357  if (attr_ptr) {
4358  fgc = attr_ptr->fgc;
4359  bgc = attr_ptr->bgc;
4360  scroll = attr_ptr->scroll;
4361  timeout = attr_ptr->timeout;
4362  prompt = attr_ptr->prompt;
4363  size_is = attr_ptr->size_is;
4364  dispattrs = attr_ptr->dispattrs;
4365  if (cb_validate_one (pos)) {
4366  return;
4367  }
4368  if (cb_validate_one (fgc)) {
4369  return;
4370  }
4371  if (cb_validate_one (bgc)) {
4372  return;
4373  }
4374  if (cb_validate_one (scroll)) {
4375  return;
4376  }
4377  if (cb_validate_one (timeout)) {
4378  return;
4379  }
4380  if (cb_validate_one (prompt)) {
4381  return;
4382  }
4383  if (cb_validate_one (size_is)) {
4384  return;
4385  }
4386  } else {
4387  fgc = NULL;
4388  bgc = NULL;
4389  scroll = NULL;
4390  timeout = NULL;
4391  prompt = NULL;
4392  size_is = NULL;
4393  dispattrs = 0;
4394  }
4395 
4396  if (prompt) {
4397  /* PROMPT character - 1 character identifier or literal */
4398  if (CB_LITERAL_P (prompt)) {
4399  if (CB_LITERAL (prompt)->size != 1) {
4400  cb_error_x (prompt, _("Invalid PROMPT literal"));
4401  return;
4402  }
4403  } else {
4404  if (CB_FIELD_PTR (prompt)->size != 1) {
4405  cb_error_x (prompt, _("Invalid PROMPT identifier"));
4406  return;
4407  }
4408  }
4409  }
4410 
4411 #if 0 /* RXWRXW - Screen */
4412  if ((CB_REF_OR_FIELD_P (var)) &&
4413  CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
4414  current_program->flag_screen = 1;
4415  }
4416 #endif
4417 
4418  if (current_program->flag_screen) {
4419  /* Bump ref count to force CRT STATUS field generation */
4420  if (current_program->crt_status) {
4421  CB_FIELD_PTR (current_program->crt_status)->count++;
4422  }
4423  if ((CB_REF_OR_FIELD_P (var)) &&
4424  CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
4425  output_screen_from (CB_FIELD (cb_ref (var)), 0);
4426  gen_screen_ptr = 1;
4427  if (pos) {
4428  if (CB_LIST_P (pos)) {
4429  line = CB_PAIR_X (pos);
4430  column = CB_PAIR_Y (pos);
4431  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4432  var, line, column, timeout));
4433  } else if (valid_screen_pos (pos)) {
4434  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4435  var, pos, NULL, timeout));
4436  }
4437  } else {
4438  cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_accept",
4439  var, NULL, NULL, timeout));
4440  }
4441  gen_screen_ptr = 0;
4442  output_screen_to (CB_FIELD (cb_ref (var)), 0);
4443  } else {
4444  if (var == cb_null) {
4445  var = NULL;
4446  }
4447  if (pos || fgc || bgc || scroll || dispattrs) {
4448  cb_gen_field_accept (var, pos, fgc, bgc, scroll,
4449  timeout, prompt, size_is, dispattrs);
4450  } else {
4451  cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
4452  var, NULL, NULL, fgc, bgc,
4453  scroll, timeout, prompt,
4454  size_is, cb_int (dispattrs)));
4455  }
4456  }
4457  } else if (pos || fgc || bgc || scroll || dispattrs) {
4458  /* Bump ref count to force CRT STATUS field generation */
4459  if (current_program->crt_status) {
4460  CB_FIELD_PTR (current_program->crt_status)->count++;
4461  }
4462  if (var == cb_null) {
4463  var = NULL;
4464  }
4465  cb_gen_field_accept (var, pos, fgc, bgc, scroll,
4466  timeout, prompt, size_is, dispattrs);
4467  } else {
4468  if (var == cb_null) {
4469  var = NULL;
4470  }
4471  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4472  }
4473 }
4474 
4475 void
4476 cb_emit_accept_line_or_col (cb_tree var, const int l_or_c)
4477 {
4478  if (cb_validate_one (var)) {
4479  return;
4480  }
4481  cb_emit (CB_BUILD_FUNCALL_2 ("cob_screen_line_col", var, cb_int (l_or_c)));
4482 }
4483 
4484 void
4485 cb_emit_accept_escape_key (cb_tree var)
4486 {
4487  if (cb_validate_one (var)) {
4488  return;
4489  }
4490  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_escape_key", var));
4491 }
4492 
4493 void
4494 cb_emit_accept_exception_status (cb_tree var)
4495 {
4496  if (cb_validate_one (var)) {
4497  return;
4498  }
4499  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_exception_status", var));
4500 }
4501 
4502 void
4503 cb_emit_accept_user_name (cb_tree var)
4504 {
4505  if (cb_validate_one (var)) {
4506  return;
4507  }
4508  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_user_name", var));
4509 }
4510 
4511 void
4512 cb_emit_accept_date (cb_tree var)
4513 {
4514  if (cb_validate_one (var)) {
4515  return;
4516  }
4517  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date", var));
4518 }
4519 
4520 void
4521 cb_emit_accept_date_yyyymmdd (cb_tree var)
4522 {
4523  if (cb_validate_one (var)) {
4524  return;
4525  }
4526  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date_yyyymmdd", var));
4527 }
4528 
4529 void
4530 cb_emit_accept_day (cb_tree var)
4531 {
4532  if (cb_validate_one (var)) {
4533  return;
4534  }
4535  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day", var));
4536 }
4537 
4538 void
4539 cb_emit_accept_day_yyyyddd (cb_tree var)
4540 {
4541  if (cb_validate_one (var)) {
4542  return;
4543  }
4544  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_yyyyddd", var));
4545 }
4546 
4547 void
4548 cb_emit_accept_day_of_week (cb_tree var)
4549 {
4550  if (cb_validate_one (var)) {
4551  return;
4552  }
4553  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_of_week", var));
4554 }
4555 
4556 void
4557 cb_emit_accept_time (cb_tree var)
4558 {
4559  if (cb_validate_one (var)) {
4560  return;
4561  }
4562  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var));
4563 }
4564 
4565 void
4566 cb_emit_accept_command_line (cb_tree var)
4567 {
4568  if (cb_validate_one (var)) {
4569  return;
4570  }
4571  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_command_line", var));
4572 }
4573 
4574 void
4575 cb_emit_get_environment (cb_tree envvar, cb_tree envval)
4576 {
4577  if (cb_validate_one (envvar)) {
4578  return;
4579  }
4580  if (cb_validate_one (envval)) {
4581  return;
4582  }
4583  cb_emit (CB_BUILD_FUNCALL_2 ("cob_get_environment", envvar, envval));
4584 }
4585 
4586 void
4587 cb_emit_accept_environment (cb_tree var)
4588 {
4589  if (cb_validate_one (var)) {
4590  return;
4591  }
4592  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_environment", var));
4593 }
4594 
4595 void
4596 cb_emit_accept_arg_number (cb_tree var)
4597 {
4598  if (cb_validate_one (var)) {
4599  return;
4600  }
4601  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_number", var));
4602 }
4603 
4604 void
4605 cb_emit_accept_arg_value (cb_tree var)
4606 {
4607  if (cb_validate_one (var)) {
4608  return;
4609  }
4610  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_value", var));
4611 }
4612 
4613 void
4614 cb_emit_accept_mnemonic (cb_tree var, cb_tree mnemonic)
4615 {
4616  if (cb_validate_one (var)) {
4617  return;
4618  }
4619  if (cb_ref (mnemonic) == cb_error_node) {
4620  return;
4621  }
4622  switch (CB_SYSTEM_NAME (cb_ref (mnemonic))->token) {
4623  case CB_DEVICE_CONSOLE:
4624  case CB_DEVICE_SYSIN:
4625  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4626  break;
4627  default:
4628  cb_error_x (mnemonic, _("Invalid input device '%s'"),
4629  cb_name (mnemonic));
4630  break;
4631  }
4632 }
4633 
4634 void
4635 cb_emit_accept_name (cb_tree var, cb_tree name)
4636 {
4637  cb_tree sys;
4638 
4639  if (cb_validate_one (var)) {
4640  return;
4641  }
4642 
4643  /* Allow direct reference to a device name */
4644  sys = lookup_system_name (CB_NAME (name));
4645  if (sys) {
4646  switch (CB_SYSTEM_NAME (sys)->token) {
4647  case CB_DEVICE_CONSOLE:
4648  case CB_DEVICE_SYSIN:
4649  if (!cb_relaxed_syntax_check) {
4650  cb_warning_x (name, _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name));
4651  }
4652  cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
4653  return;
4654  default:
4655  cb_error_x (name, _("Invalid input device '%s'"),
4656  cb_name (name));
4657  return;
4658  }
4659  }
4660 
4661  cb_error_x (name, _("'%s' is not defined in SPECIAL-NAMES"),
4662  CB_NAME (name));
4663 }
4664 
4665 /* ALLOCATE statement */
4666 
4667 void
4668 cb_emit_allocate (cb_tree target1, cb_tree target2, cb_tree size,
4669  cb_tree initialize)
4670 {
4671  cb_tree x;
4672  char buff[32];
4673 
4674  if (cb_validate_one (target1)) {
4675  return;
4676  }
4677  if (cb_validate_one (target2)) {
4678  return;
4679  }
4680  if (cb_validate_one (size)) {
4681  return;
4682  }
4683  if (cb_validate_one (initialize)) {
4684  return;
4685  }
4686  if (target1) {
4687  if (!(CB_REFERENCE_P(target1) &&
4688  CB_FIELD_PTR (target1)->flag_item_based)) {
4689  cb_error_x (CB_TREE(current_statement),
4690  _("Target of ALLOCATE is not a BASED item"));
4691  return;
4692  }
4693  }
4694  if (target2) {
4695  if (!(CB_REFERENCE_P(target2) &&
4696  CB_TREE_CLASS (target2) == CB_CLASS_POINTER)) {
4697  cb_error_x (CB_TREE(current_statement),
4698  _("Target of RETURNING is not a data pointer"));
4699  return;
4700  }
4701  }
4702  if (size) {
4703  if (CB_TREE_CLASS (size) != CB_CLASS_NUMERIC) {
4704  cb_error_x (CB_TREE(current_statement),
4705  _("The CHARACTERS field of ALLOCATE must be numeric"));
4706  return;
4707  }
4708  }
4709  if (target1) {
4710  sprintf (buff, "%d", CB_FIELD_PTR (target1)->memory_size);
4711  x = cb_build_numeric_literal (0, buff, 0);
4712  cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
4713  CB_BUILD_CAST_ADDR_OF_ADDR (target1),
4714  target2, x, NULL));
4715  } else {
4716  if (initialize && !cb_category_is_alpha (initialize)) {
4717  cb_error_x (CB_TREE(current_statement),
4718  _("INITIALIZED TO item is not alphanumeric"));
4719  }
4720  cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
4721  NULL, target2, size, initialize));
4722  }
4723  if (initialize && target1) {
4724  current_statement->handler2 =
4725  cb_build_initialize (target1, cb_true, NULL, 1, 0, 0);
4726  }
4727 }
4728 
4729 
4730 /* ALTER statement */
4731 
4732 void
4733 cb_emit_alter (cb_tree source, cb_tree target)
4734 {
4735  if (source == cb_error_node) {
4736  return;
4737  }
4738  if (target == cb_error_node) {
4739  return;
4740  }
4741  CB_REFERENCE(source)->flag_alter_code = 1;
4742  cb_emit (cb_build_alter (source, target));
4743 }
4744 
4745 /* CALL statement */
4746 
4747 void
4748 cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning,
4749  cb_tree on_exception, cb_tree not_on_exception,
4750  cb_tree convention)
4751 {
4752  cb_tree l;
4753  cb_tree x;
4754  struct cb_field *f;
4755  const struct system_table *psyst;
4756  const char *p;
4757  const char *entry;
4758  cob_s64_t val;
4759  cob_s64_t valmin;
4760  cob_s64_t valmax;
4761  cob_u32_t is_sys_call;
4762  cob_u32_t is_sys_idx;
4763  int error_ind;
4764  int call_conv;
4765  int numargs;
4766 
4767  if (CB_INTRINSIC_P (prog)) {
4768  if (CB_INTRINSIC(prog)->intr_tab->category != CB_CATEGORY_ALPHANUMERIC) {
4769  cb_error_x (CB_TREE (current_statement),
4770  _("Only alphanumeric FUNCTION types are allowed here"));
4771  return;
4772  }
4773  }
4774  if (returning && returning != cb_null) {
4775  if (CB_TREE_CLASS(returning) != CB_CLASS_NUMERIC &&
4776  CB_TREE_CLASS(returning) != CB_CLASS_POINTER) {
4777  cb_error_x (CB_TREE (current_statement),
4778  _("Invalid RETURNING field"));
4779  return;
4780  }
4781  }
4782 
4783  error_ind = 0;
4784  numargs = 0;
4785 
4786  if (convention) {
4787  if (CB_INTEGER_P (convention)) {
4788  call_conv = CB_INTEGER (convention)->val;
4789  } else {
4790  call_conv = cb_get_int (convention);
4791  }
4792  } else {
4793  call_conv = 0;
4794  }
4795 #ifndef _WIN32
4796  if (call_conv & CB_CONV_STDCALL) {
4797  call_conv &= ~CB_CONV_STDCALL;
4798  if (warningopt) {
4799  cb_warning (_("STDCALL not available on this platform"));
4800  }
4801  }
4802 #elif defined(_WIN64)
4803  if (call_conv & CB_CONV_STDCALL) {
4804  if (warningopt) {
4805  cb_warning (_("STDCALL used on 64-bit Windows platform"));
4806  }
4807  }
4808 #endif
4809  if ((call_conv & CB_CONV_STATIC_LINK) && !CB_LITERAL_P (prog)) {
4810  cb_error_x (CB_TREE (current_statement),
4811  _("STATIC CALL convention requires a literal program name"));
4812  error_ind = 1;
4813  }
4814 
4815  for (l = par_using; l; l = CB_CHAIN (l), numargs++) {
4816  x = CB_VALUE (l);
4817  if (x == cb_error_node) {
4818  error_ind = 1;
4819  continue;
4820  }
4821  if (CB_NUMERIC_LITERAL_P (x)) {
4822  if (CB_PURPOSE_INT (l) != CB_CALL_BY_VALUE) {
4823  continue;
4824  }
4825  if (CB_SIZES_INT_UNSIGNED(l) &&
4826  CB_LITERAL (x)->sign < 0) {
4827  cb_error_x (x, _("Numeric literal is negative"));
4828  error_ind = 1;
4829  continue;
4830  }
4831  val = 0;
4832  valmin = 0;
4833  valmax = 0;
4834  switch (CB_SIZES_INT (l)) {
4835  case CB_SIZE_1:
4836  val = cb_get_long_long (x);
4837  if (CB_SIZES_INT_UNSIGNED(l)) {
4838  valmin = 0;
4839  valmax = UCHAR_MAX;
4840  } else {
4841  valmin = CHAR_MIN;
4842  valmax = CHAR_MAX;
4843  }
4844  break;
4845  case CB_SIZE_2:
4846  val = cb_get_long_long (x);
4847  if (CB_SIZES_INT_UNSIGNED(l)) {
4848  valmin = 0;
4849  valmax = USHRT_MAX;
4850  } else {
4851  valmin = SHRT_MIN;
4852  valmax = SHRT_MAX;
4853  }
4854  break;
4855  case CB_SIZE_4:
4856  val = cb_get_long_long (x);
4857  if (CB_SIZES_INT_UNSIGNED(l)) {
4858  valmin = 0;
4859  valmax = UINT_MAX;
4860  } else {
4861  valmin = INT_MIN;
4862  valmax = INT_MAX;
4863  }
4864  break;
4865  case CB_SIZE_8:
4866  case CB_SIZE_AUTO:
4867  if (CB_SIZES_INT_UNSIGNED(l)) {
4868  if (CB_LITERAL (x)->size < 20) {
4869  break;
4870  }
4871  if (CB_LITERAL (x)->size > 20) {
4872  valmin = 1;
4873  break;
4874  }
4875  if (memcmp (CB_LITERAL (x)->data,
4876  "18446744073709551615",
4877  (size_t)20) > 0) {
4878  valmin = 1;
4879  break;
4880  }
4881  } else {
4882  if (CB_LITERAL (x)->size < 19) {
4883  break;
4884  }
4885  if (CB_LITERAL (x)->size > 19) {
4886  valmin = 1;
4887  break;
4888  }
4889  if (memcmp (CB_LITERAL (x)->data,
4890  "9223372036854775807",
4891  (size_t)19) > 0) {
4892  valmin = 1;
4893  break;
4894  }
4895  }
4896  break;
4897  default:
4898  break;
4899  }
4900  if (!valmin && !valmax) {
4901  continue;
4902  }
4903  if (val < valmin || val > valmax) {
4904  cb_error_x (x, _("Numeric literal exceeds size limits"));
4905  error_ind = 1;
4906  }
4907  continue;
4908  }
4909  if (CB_CONST_P (x) && x != cb_null) {
4910  cb_error_x (x, _("Figurative constant invalid here"));
4911  error_ind = 1;
4912  continue;
4913  }
4914  if ((CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) ||
4915  CB_FIELD_P (x)) {
4916  f = CB_FIELD_PTR (x);
4917  if (f->level == 88) {
4918  cb_error_x (x, _("'%s' is not a valid data name"), CB_NAME (x));
4919  error_ind = 1;
4920  continue;
4921  }
4922  if (f->flag_any_length &&
4923  CB_PURPOSE_INT (l) != CB_CALL_BY_REFERENCE) {
4924  cb_error_x (x, _("'%s' ANY LENGTH item not passed BY REFERENCE"), CB_NAME (x));
4925  error_ind = 1;
4926  continue;
4927  }
4928  if (cb_warn_call_params &&
4929  CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
4930  if (f->level != 01 && f->level != 77) {
4931  cb_warning_x (x, _("'%s' is not a 01 or 77 level item"), CB_NAME (x));
4932  }
4933  }
4934  }
4935  }
4936 
4937  is_sys_call = 0;
4938  if (CB_LITERAL_P(prog)) {
4939  entry = NULL;
4940  p = (const char *)CB_LITERAL(prog)->data;
4941  for (; *p; ++p) {
4942  if (*p == '/' || *p == '\\') {
4943  entry = p + 1;
4944  }
4945  }
4946  if (!entry) {
4947  entry = (const char *)CB_LITERAL(prog)->data;
4948  }
4949  is_sys_idx = 1;
4950  for (psyst = system_tab; psyst->syst_name; psyst++, is_sys_idx++) {
4951  if (!strcmp(entry, (const char *)psyst->syst_name)) {
4952  if (psyst->syst_params > cb_list_length (par_using)) {
4953  cb_error_x (CB_TREE (current_statement),
4954  _("Wrong number of CALL parameters for '%s'"),
4955  (char *)psyst->syst_name);
4956  return;
4957  }
4958  is_sys_call = is_sys_idx;
4959  break;
4960  }
4961  }
4962  }
4963 
4964  if (error_ind) {
4965  return;
4966  }
4967  if (numargs > current_program->max_call_param) {
4968  current_program->max_call_param = numargs;
4969  }
4970  cb_emit (cb_build_call (prog, par_using, on_exception, not_on_exception,
4971  returning, is_sys_call, call_conv));
4972 }
4973 
4974 /* CANCEL statement */
4975 
4976 void
4977 cb_emit_cancel (cb_tree prog)
4978 {
4979  if (cb_validate_one (prog)) {
4980  return;
4981  }
4982  cb_emit (cb_build_cancel (prog));
4983 }
4984 
4985 /* CLOSE statement */
4986 
4987 void
4988 cb_emit_close (cb_tree file, cb_tree opt)
4989 {
4990  struct cb_file *f;
4991 
4992  if (file == cb_error_node) {
4993  return;
4994  }
4995  file = cb_ref (file);
4996  if (file == cb_error_node) {
4997  return;
4998  }
4999  current_statement->file = file;
5000  f = CB_FILE (file);
5001 
5002  if (f->organization == COB_ORG_SORT) {
5003  cb_error_x (CB_TREE (current_statement),
5004  _("%s not allowed on %s files"), "CLOSE", "SORT");
5005  }
5006 
5007  cb_emit (CB_BUILD_FUNCALL_4 ("cob_close", file,
5008  f->file_status, opt, cb_int0));
5009 
5010  /* Check for file debugging */
5011  if (current_program->flag_debugging &&
5012  !current_statement->flag_in_debug &&
5013  CB_FILE(file)->flag_fl_debug) {
5014  cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
5015  cb_emit (cb_build_move (cb_space, cb_debug_contents));
5016  cb_emit (cb_build_debug_call (f->debug_section));
5017  }
5018 }
5019 
5020 /* COMMIT statement */
5021 
5022 void
5023 cb_emit_commit (void)
5024 {
5025  cb_emit (CB_BUILD_FUNCALL_0 ("cob_commit"));
5026 }
5027 
5028 /* CONTINUE statement */
5029 
5030 void
5031 cb_emit_continue (void)
5032 {
5033  cb_emit (cb_build_continue ());
5034 }
5035 
5036 /* DELETE statement */
5037 
5038 void
5039 cb_emit_delete (cb_tree file)
5040 {
5041  struct cb_file *f;
5042 
5043  if (file == cb_error_node) {
5044  return;
5045  }
5046  file = cb_ref (file);
5047  if (file == cb_error_node) {
5048  return;
5049  }
5050  current_statement->file = file;
5051  f = CB_FILE (file);
5052 
5053  if (f->organization == COB_ORG_SORT) {
5054  cb_error_x (CB_TREE (current_statement),
5055  _("%s not allowed on %s files"), "DELETE", "SORT");
5056  return;
5057  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
5058  cb_error_x (CB_TREE (current_statement),
5059  _("%s not allowed on %s files"), "DELETE", "LINE SEQUENTIAL");
5060  return;
5061  }
5062 
5063  /* Check for file debugging */
5064  if (current_program->flag_debugging &&
5065  !current_statement->flag_in_debug &&
5066  f->flag_fl_debug) {
5067  /* Gen callback after delete but before exception test */
5068  current_statement->flag_callback = 1;
5069  }
5070 
5071  cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete", file,
5072  f->file_status));
5073 }
5074 
5075 void
5076 cb_emit_delete_file (cb_tree file)
5077 {
5078  if (file == cb_error_node) {
5079  return;
5080  }
5081  file = cb_ref (file);
5082  if (file == cb_error_node) {
5083  return;
5084  }
5085  if (CB_FILE (file)->organization == COB_ORG_SORT) {
5086  cb_error_x (CB_TREE (current_statement),
5087  _("%s not allowed on %s files"), "DELETE FILE", "SORT");
5088  return;
5089  }
5090 
5091  /* Check for file debugging */
5092  if (current_program->flag_debugging &&
5093  !current_statement->flag_in_debug &&
5094  CB_FILE(file)->flag_fl_debug) {
5095  /* Gen callback after delete but before exception test */
5096  current_statement->flag_callback = 1;
5097  }
5098 
5099  cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete_file", file,
5100  CB_FILE(file)->file_status));
5101 }
5102 
5103 /* DISPLAY statement */
5104 
5105 void
5106 cb_emit_env_name (cb_tree value)
5107 {
5108  if (cb_validate_one (value)) {
5109  return;
5110  }
5111  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_environment", value));
5112 }
5113 
5114 void
5115 cb_emit_env_value (cb_tree value)
5116 {
5117  if (cb_validate_one (value)) {
5118  return;
5119  }
5120  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_env_value", value));
5121 }
5122 
5123 void
5124 cb_emit_arg_number (cb_tree value)
5125 {
5126  if (cb_validate_one (value)) {
5127  return;
5128  }
5129  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_arg_number", value));
5130 }
5131 
5132 void
5133 cb_emit_command_line (cb_tree value)
5134 {
5135  if (cb_validate_one (value)) {
5136  return;
5137  }
5138  cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_command_line", value));
5139 }
5140 
5141 static int
5142 validate_attrs (cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, cb_tree size_is)
5143 {
5144  return cb_validate_one (pos)
5145  || cb_validate_one (fgc)
5146  || cb_validate_one (bgc)
5147  || cb_validate_one (scroll)
5148  || cb_validate_one (size_is);
5149 }
5150 
5151 static void
5152 initialize_attrs (const struct cb_attr_struct * const attr_ptr,
5153  cb_tree * const fgc, cb_tree * const bgc,
5154  cb_tree * const scroll, cb_tree * const size_is,
5155  int * const dispattrs)
5156 {
5157  if (attr_ptr) {
5158  *fgc = attr_ptr->fgc;
5159  *bgc = attr_ptr->bgc;
5160  *scroll = attr_ptr->scroll;
5161  *size_is = attr_ptr->size_is;
5162  *dispattrs = attr_ptr->dispattrs;
5163  } else {
5164  *fgc = NULL;
5165  *bgc = NULL;
5166  *scroll = NULL;
5167  *size_is = NULL;
5168  *dispattrs = 0;
5169  }
5170 }
5171 
5172 static void
5173 get_line_and_column_from_pos (const cb_tree pos, cb_tree * const line,
5174  cb_tree * const column)
5175 {
5176  if (!pos) {
5177  *line = NULL;
5178  *column = NULL;
5179  } else if (CB_PAIR_P (pos)) {
5180  *line = CB_PAIR_X (pos);
5181  *column = CB_PAIR_Y (pos);
5182  if (*line == cb_int0) {
5183  *line = NULL;
5184  }
5185  } else if (valid_screen_pos (pos)) {
5186  *line = pos;
5187  *column = NULL;
5188  }
5189 }
5190 
5191 static void
5192 emit_screen_display (const cb_tree x, const cb_tree pos)
5193 {
5194  cb_tree line = NULL;
5195  cb_tree column = NULL;
5196 
5197  get_line_and_column_from_pos (pos, &line, &column);
5198  cb_emit (CB_BUILD_FUNCALL_3 ("cob_screen_display", x, line, column));
5199 }
5200 
5201 static void
5202 emit_field_display (const cb_tree x, const cb_tree pos, const cb_tree fgc,
5203  const cb_tree bgc, const cb_tree scroll,
5204  const cb_tree size_is, const int dispattrs)
5205 {
5206  cb_tree line = NULL;
5207  cb_tree column = NULL;
5208 
5209  get_line_and_column_from_pos (pos, &line, &column);
5210  cb_emit (CB_BUILD_FUNCALL_8 ("cob_field_display",
5211  x, line, column, fgc, bgc,
5212  scroll, size_is,
5213  cb_int (dispattrs)));
5214 }
5215 
5216 void
5217 cb_emit_display_omitted (cb_tree pos, struct cb_attr_struct *attr_ptr)
5218 {
5219  cb_tree fgc;
5220  cb_tree bgc;
5221  cb_tree scroll;
5222  cb_tree size_is; /* WITH SIZE IS */
5223  int dispattrs;
5224 
5225  initialize_attrs (attr_ptr, &fgc, &bgc, &scroll, &size_is, &dispattrs);
5226  if (validate_attrs (pos, fgc, bgc, scroll, size_is)) {
5227  return;
5228  }
5229 
5230  /* TODO: Implement */
5231  /* Should we create a distinct omitted_display function in screenio.c? */
5232  /* emit_field_display (NULL, pos, fgc, bgc, scroll, size_is, dispattrs); */
5233 }
5234 
5235 void
5236 cb_emit_display (cb_tree values, cb_tree upon, cb_tree no_adv, cb_tree pos,
5237  struct cb_attr_struct *attr_ptr)
5238 {
5239  cb_tree l;
5240  cb_tree x;
5241  cb_tree p;
5242  cb_tree fgc;
5243  cb_tree bgc;
5244  cb_tree scroll;
5245  cb_tree size_is; /* WITH SIZE IS */
5246  int dispattrs;
5247 
5248  if (cb_validate_list (values)) {
5249  return;
5250  }
5251 
5252  initialize_attrs (attr_ptr, &fgc, &bgc, &scroll, &size_is, &dispattrs);
5253  if (validate_attrs (pos, fgc, bgc, scroll, size_is)) {
5254  return;
5255  }
5256 
5257  for (l = values; l; l = CB_CHAIN (l)) {
5258  x = CB_VALUE (l);
5259  if (x == cb_error_node) {
5260  return;
5261  }
5262 
5263  switch (CB_TREE_TAG (x)) {
5264  case CB_TAG_LITERAL:
5265  case CB_TAG_INTRINSIC:
5266  case CB_TAG_CONST:
5267  case CB_TAG_STRING:
5268  case CB_TAG_INTEGER:
5269  break;
5270  case CB_TAG_REFERENCE:
5271  if (!CB_FIELD_P(CB_REFERENCE(x)->value)) {
5272  cb_error_x (x, _("'%s' is an invalid type for DISPLAY operand"), cb_name (x));
5273  return;
5274  }
5275  break;
5276  default:
5277  cb_error_x (x, _("Invalid type for DISPLAY operand"));
5278  return;
5279  }
5280  }
5281  if (upon == cb_error_node
5282  || !values /* <- silence warnings */) {
5283  return;
5284  }
5285 
5286 
5287  x = CB_VALUE (values);
5288  if ((CB_REF_OR_FIELD_P (x)) &&
5289  CB_FIELD (cb_ref (x))->storage == CB_STORAGE_SCREEN) {
5290  output_screen_from (CB_FIELD (cb_ref (x)), 0);
5291  gen_screen_ptr = 1;
5292  emit_screen_display (x, pos);
5293  gen_screen_ptr = 0;
5294  } else if (pos || fgc || bgc || scroll || size_is || dispattrs || upon == cb_null) {
5295  for (l = values; l; l = CB_CHAIN (l)) {
5296  x = CB_VALUE (l);
5297  /* low-values position cursor, size does not matter */
5298  if (x == cb_low) {
5299  dispattrs |= COB_SCREEN_NO_DISP;
5300  }
5301  /* no WITH SIZE then SPACE clears to end of screen */
5302  if (!(size_is)) {
5303  if (x == cb_space) {
5304  dispattrs |= COB_SCREEN_ERASE_EOS;
5305  dispattrs |= COB_SCREEN_NO_DISP;
5306  } else if (x == cb_low) {
5307  dispattrs |= COB_SCREEN_NO_DISP;
5308  } else if (CB_LITERAL_P (x) && CB_LITERAL (x)->all &&
5309  CB_LITERAL (x)->size == 1) {
5310  if (CB_LITERAL (x)->data[0] == 1) {
5311  dispattrs |= COB_SCREEN_ERASE_EOL;
5312  dispattrs |= COB_SCREEN_NO_DISP;
5313  } else if (CB_LITERAL (x)->data[0] == 2) {
5314  cb_emit (CB_BUILD_FUNCALL_0 ("cob_sys_clear_screen"));
5315  return;
5316  } else if (CB_LITERAL (x)->data[0] == 7) {
5317  dispattrs |= COB_SCREEN_BELL;
5318  dispattrs |= COB_SCREEN_NO_DISP;
5319  }
5320  }
5321  }
5322  emit_field_display (x, pos, fgc, bgc, scroll, size_is, dispattrs);
5323  }
5324  } else {
5325  /* DISPLAY x ... [UPON device-name] */
5326  p = CB_BUILD_FUNCALL_3 ("cob_display", upon, no_adv, values);
5327  CB_FUNCALL(p)->varcnt = cb_list_length (values);
5328  CB_FUNCALL(p)->nolitcast = 1;
5329  cb_emit (p);
5330  for (l = values; l; l = CB_CHAIN (l)) {
5331  x = CB_VALUE (l);
5332  if (CB_FIELD_P (x)) {
5333  CB_FIELD (cb_ref (x))->count++;
5334  }
5335  }
5336  }
5337 }
5338 
5339 cb_tree
5340 cb_build_display_mnemonic (cb_tree x)
5341 {
5342  if (x == cb_error_node) {
5343  return cb_int0;
5344  }
5345  if (cb_ref (x) == cb_error_node) {
5346  return cb_int0;
5347  }
5348 
5349  switch (CB_SYSTEM_NAME (cb_ref (x))->token) {
5350  case CB_DEVICE_CONSOLE:
5351  case CB_DEVICE_SYSOUT:
5352  return cb_int0;
5353  case CB_DEVICE_SYSERR:
5354  return cb_int1;
5355  default:
5356  cb_error_x (x, _("Invalid output device"));
5357  return cb_int0;
5358  }
5359 }
5360 
5361 cb_tree
5362 cb_build_display_name (cb_tree x)
5363 {
5364  const char *name;
5365  cb_tree sys;
5366 
5367  if (x == cb_error_node) {
5368  return cb_error_node;
5369  }
5370  name = CB_NAME (x);
5371  /* Allow direct reference to a device name */
5372  sys = lookup_system_name (name);
5373  if (sys) {
5374  switch (CB_SYSTEM_NAME (sys)->token) {
5375  case CB_DEVICE_CONSOLE:
5376  case CB_DEVICE_SYSOUT:
5377  if (!cb_relaxed_syntax_check) {
5378  cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5379  }
5380  return cb_int0;
5381  case CB_DEVICE_SYSERR:
5382  if (!cb_relaxed_syntax_check) {
5383  cb_warning_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5384  }
5385  return cb_int1;
5386  default:
5387  cb_error_x (x, _("'%s' is not an output device"), name);
5388  return cb_error_node;
5389  }
5390  }
5391 
5392  cb_error_x (x, _("'%s' is not defined in SPECIAL-NAMES"), name);
5393  return cb_error_node;
5394 }
5395 
5396 /* DIVIDE statement */
5397 
5398 void
5399 cb_emit_divide (cb_tree dividend, cb_tree divisor, cb_tree quotient,
5400  cb_tree remainder)
5401 {
5402  if (cb_validate_one (dividend)) {
5403  return;
5404  }
5405  if (cb_validate_one (divisor)) {
5406  return;
5407  }
5408  CB_VALUE (quotient) = cb_check_numeric_edited_name (CB_VALUE (quotient));
5409  CB_VALUE (remainder) = cb_check_numeric_edited_name (CB_VALUE (remainder));
5410 
5411  if (cb_validate_one (CB_VALUE (quotient))) {
5412  return;
5413  }
5414  if (cb_validate_one (CB_VALUE (remainder))) {
5415  return;
5416  }
5417 
5418  cb_emit (CB_BUILD_FUNCALL_4 ("cob_div_quotient", dividend, divisor,
5419  CB_VALUE (quotient),
5420  build_store_option (CB_VALUE (quotient),
5421  CB_PURPOSE (quotient))));
5422  cb_emit (CB_BUILD_FUNCALL_2 ("cob_div_remainder", CB_VALUE (remainder),
5423  build_store_option (CB_VALUE (remainder),
5424  cb_int0)));
5425 }
5426 
5427 /* EVALUATE statement */
5428 
5429 static cb_tree
5430 evaluate_test (cb_tree s, cb_tree o)
5431 {
5432  cb_tree x;
5433  cb_tree y;
5434  cb_tree t;
5435  int flag;
5436 
5437  /* ANY is always true */
5438  if (o == cb_any) {
5439  return cb_true;
5440  }
5441 
5442  /* Object TRUE or FALSE */
5443  if (o == cb_true) {
5444  return s;
5445  }
5446  if (o == cb_false) {
5447  return CB_BUILD_NEGATION (s);
5448  }
5449 
5450  flag = CB_PURPOSE_INT (o);
5451  x = CB_PAIR_X (CB_VALUE (o));
5452  y = CB_PAIR_Y (CB_VALUE (o));
5453 
5454  /* Subject TRUE or FALSE */
5455  if (s == cb_true) {
5456  return flag ? CB_BUILD_NEGATION (x) : x;
5457  }
5458  if (s == cb_false) {
5459  return flag ? x : CB_BUILD_NEGATION (x);
5460  }
5461 
5462  /* x THRU y */
5463  if (y) {
5464  t = cb_build_binary_op (cb_build_binary_op (x, '[', s),
5465  '&',
5466  cb_build_binary_op (s, '[', y));
5467 
5468  return flag ? CB_BUILD_NEGATION (t) : t;
5469  }
5470 
5471  if (CB_REFERENCE_P(x) && CB_FIELD_P(CB_REFERENCE(x)->value) &&
5472  CB_FIELD(CB_REFERENCE(x)->value)->level == 88) {
5473  cb_error_x (CB_TREE (current_statement),
5474  _("Invalid use of 88 level in WHEN expression"));
5475  return NULL;
5476  }
5477 
5478  /* Regular comparison */
5479  switch (flag) {
5480  case 0:
5481  /* Equal comparison */
5482  return cb_build_binary_op (s, '=', x);
5483  case 1:
5484  /* Unequal comparison */
5485  return cb_build_binary_op (s, '~', x);
5486  default:
5487  /* Class and relational conditions */
5488  return x;
5489  }
5490 }
5491 
5492 static void
5493 build_evaluate (cb_tree subject_list, cb_tree case_list, cb_tree labid)
5494 {
5495  cb_tree c1;
5496  cb_tree c2;
5497  cb_tree c3;
5498  cb_tree subjs;
5499  cb_tree whens;
5500  cb_tree objs;
5501  cb_tree stmt;
5502 
5503  if (case_list == NULL) {
5504  return;
5505  }
5506 
5507  whens = CB_VALUE (case_list);
5508  stmt = CB_VALUE (whens);
5509  whens = CB_CHAIN (whens);
5510  c1 = NULL;
5511 
5512  /* For each WHEN sequence */
5513  for (; whens; whens = CB_CHAIN (whens)) {
5514  c2 = NULL;
5515  /* Single WHEN test */
5516  for (subjs = subject_list, objs = CB_VALUE (whens);
5517  subjs && objs;
5518  subjs = CB_CHAIN (subjs), objs = CB_CHAIN (objs)) {
5519  c3 = evaluate_test (CB_VALUE (subjs), CB_VALUE (objs));
5520  if (c3 == NULL || c3 == cb_error_node) {
5521  return;
5522  }
5523 
5524  if (c2 == NULL) {
5525  c2 = c3;
5526  } else {
5527  c2 = cb_build_binary_op (c2, '&', c3);
5528  if (c2 == cb_error_node) {
5529  return;
5530  }
5531  }
5532  }
5533  if (subjs || objs) {
5534  cb_error (_("Wrong number of WHEN parameters"));
5535  }
5536  /* Connect multiple WHEN's */
5537  if (c1 == NULL) {
5538  c1 = c2;
5539  } else {
5540  c1 = cb_build_binary_op (c1, '|', c2);
5541  if (c1 == cb_error_node) {
5542  return;
5543  }
5544  }
5545  }
5546 
5547  if (c1 == NULL) {
5548  cb_emit (cb_build_comment ("WHEN OTHER"));
5549  cb_emit (stmt);
5550  } else {
5551  c2 = stmt;
5552  /* Check if last statement is GO TO */
5553  for (c3 = stmt; c3; c3 = CB_CHAIN (c3)) {
5554  if (!CB_CHAIN(c3)) {
5555  break;
5556  }
5557  }
5558  if (c3 && CB_VALUE (c3) && CB_STATEMENT_P (CB_VALUE (c3))) {
5559  c3 = CB_STATEMENT(CB_VALUE(c3))->body;
5560  if (c3 && CB_VALUE (c3) && !CB_GOTO_P (CB_VALUE(c3))) {
5561  /* Append the jump */
5562  c2 = cb_list_add (stmt, labid);
5563  }
5564  }
5565  cb_emit (cb_build_if (cb_build_cond (c1), c2, NULL, 0));
5566  build_evaluate (subject_list, CB_CHAIN (case_list), labid);
5567  }
5568 }
5569 
5570 void
5571 cb_emit_evaluate (cb_tree subject_list, cb_tree case_list)
5572 {
5573  cb_tree x;
5574  char sbuf[16];
5575 
5576  snprintf (sbuf, sizeof(sbuf), "goto %s%d;", CB_PREFIX_LABEL, cb_id);
5577  x = cb_build_direct (cobc_parse_strdup (sbuf), 0);
5578  build_evaluate (subject_list, case_list, x);
5579  snprintf (sbuf, sizeof(sbuf), "%s%d:;", CB_PREFIX_LABEL, cb_id);
5580  cb_emit (cb_build_comment ("End EVALUATE"));
5581  cb_emit (cb_build_direct (cobc_parse_strdup (sbuf), 0));
5582  cb_id++;
5583 }
5584 
5585 /* FREE statement */
5586 
5587 void
5588 cb_emit_free (cb_tree vars)
5589 {
5590  cb_tree l;
5591  struct cb_field *f;
5592  int i;
5593 
5594  if (cb_validate_list (vars)) {
5595  return;
5596  }
5597  for (l = vars, i = 1; l; l = CB_CHAIN (l), i++) {
5598  if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_POINTER) {
5599  if (CB_CAST_P (CB_VALUE (l))) {
5600  f = CB_FIELD_PTR (CB_CAST (CB_VALUE(l))->val);
5601  if (!f->flag_item_based) {
5602  cb_error_x (CB_TREE (current_statement),
5603  _("Target %d of FREE is not a BASED data item"), i);
5604  }
5605  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5606  CB_BUILD_CAST_ADDRESS (CB_VALUE (l)), NULL));
5607  } else {
5608  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5609  NULL, CB_BUILD_CAST_ADDRESS (CB_VALUE (l))));
5610  }
5611  } else if (CB_REF_OR_FIELD_P (CB_VALUE (l))) {
5612  f = CB_FIELD_PTR (CB_VALUE (l));
5613  if (!f->flag_item_based) {
5614  cb_error_x (CB_TREE (current_statement),
5615  _("Target %d of FREE is not a BASED data item"), i);
5616  }
5617  cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
5618  CB_BUILD_CAST_ADDR_OF_ADDR (CB_VALUE (l)), NULL));
5619  } else {
5620  cb_error_x (CB_TREE (current_statement),
5621  _("Target %d of FREE must be a data pointer"), i);
5622  }
5623  }
5624 }
5625 
5626 /* GO TO statement */
5627 
5628 void
5629 cb_emit_goto (cb_tree target, cb_tree depending)
5630 {
5631  if (target == cb_error_node) {
5632  return;
5633  }
5634  if (target == NULL) {
5635  cb_verify (cb_goto_statement_without_name, _("GO TO without procedure-name"));
5636  } else if (depending) {
5637  /* GO TO procedure-name ... DEPENDING ON identifier */
5638  if (cb_check_numeric_value (depending) == cb_error_node) {
5639  return;
5640  }
5641  cb_check_data_incompat (depending);
5642  cb_emit (cb_build_goto (target, depending));
5643  } else if (CB_CHAIN (target)) {
5644  cb_error_x (CB_TREE (current_statement),
5645  _("GO TO with multiple procedure-names"));
5646  } else {
5647  /* GO TO procedure-name */
5648  cb_emit (cb_build_goto (CB_VALUE (target), NULL));
5649  }
5650 }
5651 
5652 void
5653 cb_emit_exit (const unsigned int goback)
5654 {
5655  if (goback) {
5656  cb_emit (cb_build_goto (cb_int1, NULL));
5657  } else {
5658  cb_emit (cb_build_goto (NULL, NULL));
5659  }
5660 }
5661 
5662 /* IF statement */
5663 
5664 void
5665 cb_emit_if (cb_tree cond, cb_tree stmt1, cb_tree stmt2)
5666 {
5667  cb_emit (cb_build_if (cond, stmt1, stmt2, 1));
5668 }
5669 
5670 cb_tree
5671 cb_build_if_check_break (cb_tree cond, cb_tree stmts)
5672 {
5673  cb_tree stmt_lis;
5674 
5675  stmt_lis = cb_check_needs_break (stmts);
5676  return cb_build_if (cond, stmt_lis, NULL, 0);
5677 }
5678 
5679 /* INITIALIZE statement */
5680 
5681 void
5682 cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value,
5683  cb_tree replacing, cb_tree def)
5684 {
5685  cb_tree l;
5686  unsigned int no_fill_init;
5687  unsigned int def_init;
5688  cb_tree x;
5689 
5690  if (cb_validate_list (vars)) {
5691  return;
5692  }
5693  if (value == NULL && replacing == NULL) {
5694  def = cb_true;
5695  }
5696  no_fill_init = (fillinit == NULL);
5697  def_init = (def != NULL);
5698  for (l = vars; l; l = CB_CHAIN (l)) {
5699  x = CB_VALUE (l);
5700  if (!(CB_REFERENCE_P (x) && CB_FIELD_P (CB_REFERENCE (x)->value)) &&
5701  !CB_FIELD_P (x)) {
5702  cb_error_x (CB_TREE (current_statement), _("Invalid INITIALIZE statement"));
5703  return;
5704  }
5705 
5706  cb_emit (cb_build_initialize (x , value, replacing,
5707  def_init, 1, no_fill_init));
5708  }
5709 }
5710 
5711 /* INSPECT statement */
5712 
5713 static void
5714 validate_inspect (cb_tree x, cb_tree y, const unsigned int replconv)
5715 {
5716  cb_tree l;
5717  struct cb_reference *r;
5718  size_t size1;
5719  size_t size2;
5720  int offset;
5721 
5722  size1 = 0;
5723  size2 = 0;
5724  switch (CB_TREE_TAG(x)) {
5725  case CB_TAG_REFERENCE:
5726  r = CB_REFERENCE (x);
5727  l = cb_ref (x);
5728  if (l == cb_error_node) {
5729  return;
5730  }
5731  if (CB_REF_OR_FIELD_P (l)) {
5732  size1 = CB_FIELD_PTR (x)->size;
5733  } else if (CB_ALPHABET_NAME_P (l)) {
5734  size1 = 256;
5735  }
5736  if (size1 && r->offset) {
5737  if (!CB_LITERAL_P (r->offset)) {
5738  return;
5739  }
5740  offset = cb_get_int (r->offset);
5741  if (r->length) {
5742  if (!CB_LITERAL_P (r->length)) {
5743  return;
5744  }
5745  size1 = cb_get_int (r->length);
5746  } else {
5747  size1 -= (offset - 1);
5748  }
5749  }
5750  break;
5751  case CB_TAG_LITERAL:
5752  size1 = CB_LITERAL(x)->size;
5753  break;
5754  case CB_TAG_CONST:
5755  size1 = 1;
5756  break;
5757  default:
5758  break;
5759  }
5760  switch (CB_TREE_TAG(y)) {
5761  case CB_TAG_REFERENCE:
5762  r = CB_REFERENCE (y);
5763  l = cb_ref (y);
5764  if (l == cb_error_node) {
5765  return;
5766  }
5767  if (CB_REF_OR_FIELD_P (l)) {
5768  size2 = CB_FIELD_PTR (y)->size;
5769  } else if (CB_ALPHABET_NAME_P (l)) {
5770  size2 = 256;
5771  }
5772  if (size2 && r->offset) {
5773  if (!CB_LITERAL_P (r->offset)) {
5774  return;
5775  }
5776  offset = cb_get_int (r->offset);
5777  if (r->length) {
5778  if (!CB_LITERAL_P (r->length)) {
5779  return;
5780  }
5781  size2 = cb_get_int (r->length);
5782  } else {
5783  size2 -= (offset - 1);
5784  }
5785  }
5786  break;
5787  case CB_TAG_LITERAL:
5788  size2 = CB_LITERAL(y)->size;
5789  break;
5790  default:
5791  break;
5792  }
5793  if (size1 && size2 && size1 != size2) {
5794  if (replconv == 1) {
5795  cb_error_x (CB_TREE (current_statement),
5796  _("%s operands differ in size"), "REPLACING");
5797  } else {
5798  cb_error_x (CB_TREE (current_statement),
5799  _("%s operands differ in size"), "CONVERTING");
5800  }
5801  }
5802 }
5803 
5804 void
5805 cb_emit_inspect (cb_tree var, cb_tree body, cb_tree replacing,
5806  const unsigned int replconv)
5807 {
5808  switch (CB_TREE_TAG(var)) {
5809  case CB_TAG_REFERENCE:
5810  break;
5811  case CB_TAG_INTRINSIC:
5812  if (replconv) {
5813  goto rep_error;
5814  }
5815  switch (CB_TREE_CATEGORY(var)) {
5816  case CB_CATEGORY_ALPHABETIC:
5817  case CB_CATEGORY_ALPHANUMERIC:
5818  case CB_CATEGORY_NATIONAL:
5819  break;
5820  default:
5821  cb_error_x (CB_TREE (current_statement),
5822  _("Invalid target for %s"), "CONVERTING");
5823  return;
5824  }
5825  break;
5826  case CB_TAG_LITERAL:
5827  if (replconv) {
5828  goto rep_error;
5829  }
5830  break;
5831  default:
5832  goto rep_error;
5833  }
5834  cb_emit (CB_BUILD_FUNCALL_2 ("cob_inspect_init", var, replacing));
5835  cb_emit_list (body);
5836  cb_emit (CB_BUILD_FUNCALL_0 ("cob_inspect_finish"));
5837  return;
5838 rep_error:
5839  if (replconv == 1) {
5840  cb_error_x (CB_TREE (current_statement),
5841  _("Invalid target for %s"), "REPLACING");
5842  } else {
5843  cb_error_x (CB_TREE (current_statement),
5844  _("Invalid target for %s"), "CONVERTING");
5845  }
5846 }
5847 
5848 void
5849 cb_init_tallying (void)
5850 {
5851  inspect_func = NULL;
5852  inspect_data = NULL;
5853 }
5854 
5855 cb_tree
5856 cb_build_tallying_data (cb_tree x)
5857 {
5858  inspect_data = x;
5859  return NULL;
5860 }
5861 
5862 cb_tree
5863 cb_build_tallying_characters (cb_tree l)
5864 {
5865  if (inspect_data == NULL) {
5866  cb_error_x (CB_TREE (current_statement),
5867  _("Data name expected before CHARACTERS"));
5868  }
5869  inspect_func = NULL;
5870  return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", inspect_data));
5871 }
5872 
5873 cb_tree
5874 cb_build_tallying_all (void)
5875 {
5876  if (inspect_data == NULL) {
5877  cb_error_x (CB_TREE (current_statement),
5878  _("Data name expected before ALL"));
5879  }
5880  inspect_func = "cob_inspect_all";
5881  return NULL;
5882 }
5883 
5884 cb_tree
5885 cb_build_tallying_leading (void)
5886 {
5887  if (inspect_data == NULL) {
5888  cb_error_x (CB_TREE (current_statement),
5889  _("Data name expected before LEADING"));
5890  }
5891  inspect_func = "cob_inspect_leading";
5892  return NULL;
5893 }
5894 
5895 cb_tree
5896 cb_build_tallying_trailing (void)
5897 {
5898  if (inspect_data == NULL) {
5899  cb_error_x (CB_TREE (current_statement),
5900  _("Data name expected before TRAILING"));
5901  }
5902  inspect_func = "cob_inspect_trailing";
5903  return NULL;
5904 }
5905 
5906 cb_tree
5907 cb_build_tallying_value (cb_tree x, cb_tree l)
5908 {
5909  if (inspect_func == NULL) {
5910  cb_error_x (x, _("ALL, LEADING or TRAILING expected before '%s'"), cb_name (x));
5911  }
5912  return cb_list_add (l, CB_BUILD_FUNCALL_2 (inspect_func, inspect_data, x));
5913 }
5914 
5915 cb_tree
5916 cb_build_replacing_characters (cb_tree x, cb_tree l)
5917 {
5918  if (CB_LITERAL_P (x) && CB_LITERAL(x)->size != 1) {
5919  cb_error_x (CB_TREE (current_statement),
5920  _("Operand has wrong size"));
5921  }
5922  return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", x));
5923 }
5924 
5925 cb_tree
5926 cb_build_replacing_all (cb_tree x, cb_tree y, cb_tree l)
5927 {
5928  validate_inspect (x, y, 1);
5929  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_all", y, x));
5930 }
5931 
5932 cb_tree
5933 cb_build_replacing_leading (cb_tree x, cb_tree y, cb_tree l)
5934 {
5935  validate_inspect (x, y, 1);
5936  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_leading", y, x));
5937 }
5938 
5939 cb_tree
5940 cb_build_replacing_first (cb_tree x, cb_tree y, cb_tree l)
5941 {
5942  validate_inspect (x, y, 1);
5943  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_first", y, x));
5944 }
5945 
5946 cb_tree
5947 cb_build_replacing_trailing (cb_tree x, cb_tree y, cb_tree l)
5948 {
5949  validate_inspect (x, y, 1);
5950  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_trailing", y, x));
5951 }
5952 
5953 cb_tree
5954 cb_build_converting (cb_tree x, cb_tree y, cb_tree l)
5955 {
5956  validate_inspect (x, y, 2);
5957  return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_converting", x, y));
5958 }
5959 
5960 cb_tree
5961 cb_build_inspect_region_start (void)
5962 {
5963  return CB_LIST_INIT (CB_BUILD_FUNCALL_0 ("cob_inspect_start"));
5964 }
5965 
5966 /* MOVE statement */
5967 
5968 static void
5969 warning_destination (cb_tree x)
5970 {
5971  struct cb_reference *r;
5972  struct cb_field *f;
5973  cb_tree loc;
5974 
5975  r = CB_REFERENCE (x);
5976  f = CB_FIELD (r->value);
5977  loc = CB_TREE (f);
5978 
5979  if (r->offset) {
5980  return;
5981  }
5982 
5983  if (!strcmp (f->name, "RETURN-CODE") ||
5984  !strcmp (f->name, "SORT-RETURN") ||
5985  !strcmp (f->name, "NUMBER-OF-CALL-PARAMETERS")) {
5986  cb_warning (_("Internal register '%s' defined as BINARY-LONG"),
5987  f->name);
5988  } else if (f->flag_real_binary) {
5989  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
5990  f->name, f->pic->orig);
5991  } else if (f->usage == CB_USAGE_FLOAT) {
5992  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
5993  f->name, "FLOAT");
5994  } else if (f->usage == CB_USAGE_DOUBLE) {
5995  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
5996  f->name, "DOUBLE");
5997  } else if (f->usage == CB_USAGE_LONG_DOUBLE) {
5998  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
5999  f->name, "FLOAT EXTENDED");
6000  } else if (f->usage == CB_USAGE_FP_BIN32) {
6001  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
6002  f->name, "FLOAT-BINARY-7");
6003  } else if (f->usage == CB_USAGE_FP_BIN64) {
6004  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
6005  f->name, "FLOAT-BINARY-16");
6006  } else if (f->usage == CB_USAGE_FP_BIN128) {
6007  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
6008  f->name, "FLOAT-BINARY-34");
6009  } else if (f->usage == CB_USAGE_FP_DEC64) {
6010  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
6011  f->name, "FLOAT-DECIMAL-16");
6012  } else if (f->usage == CB_USAGE_FP_DEC128) {
6013  cb_warning_x (loc, _("'%s' defined here as USAGE %s"),
6014  f->name, "FLOAT-DECIMAL-34");
6015  } else if (f->pic) {
6016  cb_warning_x (loc, _("'%s' defined here as PIC %s"),
6017  cb_name (loc), f->pic->orig);
6018  } else {
6019  cb_warning_x (loc, _("'%s' defined here as a group of length %d"),
6020  cb_name (loc), f->size);
6021  }
6022 }
6023 
6024 static void
6025 move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag,
6026  const int flag, const int src_flag, const char *msg)
6027 {
6028  cb_tree loc;
6029 
6030  if (suppress_warn) {
6031  return;
6032  }
6033  loc = src->source_line ? src : dst;
6034  if (value_flag) {
6035  /* VALUE clause */
6036  if (CB_LITERAL_P (src)) {
6037  cb_warning_x (dst, msg);
6038  } else {
6039  cb_warning_x (loc, msg);
6040  }
6041  } else {
6042  /* MOVE statement */
6043  if (flag) {
6044  if (CB_LITERAL_P (src)) {
6045  cb_warning_x (dst, msg);
6046  } else {
6047  cb_warning_x (loc, msg);
6048  }
6049  if (src_flag) {
6050  warning_destination (src);
6051  }
6052  warning_destination (dst);
6053  }
6054  }
6055 
6056  return;
6057 }
6058 
6059 static int
6060 count_pic_alphanumeric_edited (struct cb_field *field)
6061 {
6062  unsigned char *p;
6063  int count;
6064  int repeat;
6065 
6066  /* Count number of free places in an alphanumeric edited field */
6067  count = 0;
6068  for (p = (unsigned char *)(field->pic->str); *p; p += 5) {
6069  if (*p == '9' || *p == 'A' || *p == 'X') {
6070  memcpy ((void *)&repeat, p + 1, sizeof(int));
6071  count += repeat;
6072  }
6073  }
6074  return count;
6075 }
6076 
6077 static size_t
6078 cb_check_overlapping (cb_tree src, cb_tree dst,
6079  struct cb_field *src_f, struct cb_field *dst_f)
6080 {
6081  struct cb_field *f1;
6082  struct cb_field *ff1;
6083  struct cb_field *ff2;
6084  struct cb_reference *r;
6085  cb_tree loc;
6086  int src_size;
6087  int dst_size;
6088  int src_off;
6089  int dst_off;
6090 
6091  /* Check basic overlapping */
6092  for (f1 = src_f->children; f1; f1 = f1->sister) {
6093  if (f1 == dst_f) {
6094  goto overlapret;
6095  }
6096  }
6097  for (f1 = dst_f->children; f1; f1 = f1->sister) {
6098  if (f1 == src_f) {
6099  goto overlapret;
6100  }
6101  }
6102  ff1 = cb_field_founder (src_f);
6103  ff2 = cb_field_founder (dst_f);
6104  if (ff1->redefines) {
6105  ff1 = ff1->redefines;
6106  }
6107  if (ff2->redefines) {
6108  ff2 = ff2->redefines;
6109  }
6110  if (ff1 != ff2) {
6111  return 0;
6112  }
6113 
6114  src_size = cb_field_size (src);
6115  dst_size = cb_field_size (dst);
6116 
6117  if (src_size <= 0 || dst_size <= 0 ||
6118  cb_field_variable_size (src_f) ||
6119  cb_field_variable_size (dst_f)) {
6120  return 1; /* overlapping possible, would need more checks */
6121  }
6122  /* Check literal occurs? */
6123  if ((src_f->flag_occurs && !src_f->mem_offset) ||
6124  (dst_f->flag_occurs && !dst_f->mem_offset)) {
6125  return 1; /* overlapping possible, would need more checks */
6126  }
6127 
6128  /* Same field - Check offsets */
6129  src_off = src_f->offset;
6130  dst_off = dst_f->offset;
6131 
6132  /* Adjusting offsets by occurs and reference modification */
6133  src_off += src_f->mem_offset ;
6134  r = CB_REFERENCE (src);
6135  if (r->offset) {
6136  if (CB_LITERAL_P (r->offset)) {
6137  src_off += cb_get_int (r->offset) - 1;
6138  } else {
6139  goto overlapret;
6140  }
6141  }
6142  dst_off += dst_f->mem_offset;
6143  r = CB_REFERENCE (dst);
6144  if (r->offset) {
6145  if (CB_LITERAL_P (r->offset)) {
6146  dst_off += cb_get_int (r->offset) - 1;
6147  } else {
6148  goto overlapret;
6149  }
6150  }
6151  if (src_off >= dst_off && src_off < (dst_off + dst_size)) {
6152  goto overlapret;
6153  }
6154  if (src_off < dst_off && (src_off + src_size) > dst_off) {
6155  goto overlapret;
6156  }
6157  return 0;
6158 overlapret:
6159  loc = src->source_line ? src : dst;
6160  if (cb_warn_overlap && !suppress_warn) {
6161  cb_warning_x (loc, _("Overlapping MOVE may produce unpredictable results"));
6162  }
6163  return 1;
6164 }
6165 
6166 int
6167 validate_move (cb_tree src, cb_tree dst, const unsigned int is_value)
6168 {
6169  struct cb_field *fdst;
6170  struct cb_field *fsrc;
6171  struct cb_literal *l;
6172  unsigned char *p;
6173  cb_tree loc;
6174  cob_s64_t val;
6175  size_t i;
6176  size_t is_numeric_edited;
6177  int src_scale_mod;
6178  int dst_scale_mod;
6179  int dst_size_mod;
6180  int size;
6181  int most_significant;
6182  int least_significant;
6183 
6184  loc = src->source_line ? src : dst;
6185  is_numeric_edited = 0;
6186  overlapping = 0;
6187  if (CB_REFERENCE_P (dst)) {
6188  if (CB_ALPHABET_NAME_P(CB_REFERENCE(dst)->value)) {
6189  goto invalid;
6190  }
6191  if (CB_FILE_P(CB_REFERENCE(dst)->value)) {
6192  goto invalid;
6193  }
6194  }
6195  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN) {
6196  cb_error_x (loc, _("Invalid destination for MOVE"));
6197  return -1;
6198  }
6199 
6200  if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
6201  if (CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
6202  return 0;
6203  } else {
6204  goto invalid;
6205  }
6206  }
6207 
6208  fdst = CB_FIELD_PTR (dst);
6209  switch (CB_TREE_TAG (src)) {
6210  case CB_TAG_CONST:
6211  if (src == cb_space) {
6212  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
6213  (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED && !is_value)) {
6214  if (!cb_relaxed_syntax_check || is_value) {
6215  goto invalid;
6216  }
6217  cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
6218  }
6219  } else if (src == cb_zero) {
6220  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC) {
6221  goto invalid;
6222  }
6223  } else if (src == cb_low || src == cb_high || src == cb_quote) {
6224  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
6225  CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED) {
6226  if (!cb_relaxed_syntax_check || is_value) {
6227  goto invalid;
6228  }
6229  cb_warning_x (loc, _("Source is non-numeric - substituting zero"));
6230  }
6231  }
6232  break;
6233  case CB_TAG_LITERAL:
6234  l = CB_LITERAL (src);
6235  if (CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
6236  /* Numeric literal */
6237  if (l->all) {
6238  goto invalid;
6239  }
6240  if (fdst->usage == CB_USAGE_DOUBLE ||
6241  fdst->usage == CB_USAGE_FLOAT ||
6242  fdst->usage == CB_USAGE_LONG_DOUBLE ||
6243  fdst->usage == CB_USAGE_FP_BIN32 ||
6244  fdst->usage == CB_USAGE_FP_BIN64 ||
6245  fdst->usage == CB_USAGE_FP_BIN128 ||
6246  fdst->usage == CB_USAGE_FP_DEC64 ||
6247  fdst->usage == CB_USAGE_FP_DEC128) {
6248  break;
6249  }
6250  most_significant = -999;
6251  least_significant = 999;
6252 
6253  /* Compute the most significant figure place */
6254  for (i = 0; i < l->size; i++) {
6255  if (l->data[i] != '0') {
6256  break;
6257  }
6258  }
6259  if (i != l->size) {
6260  most_significant = (int) (l->size - l->scale - i - 1);
6261  }
6262 
6263  /* Compute the least significant figure place */
6264  for (i = 0; i < l->size; i++) {
6265  if (l->data[l->size - i - 1] != '0') {
6266  break;
6267  }
6268  }
6269  if (i != l->size) {
6270  least_significant = (int) (-l->scale + i);
6271  }
6272 
6273  /* Value check */
6274  switch (CB_TREE_CATEGORY (dst)) {
6275  case CB_CATEGORY_ALPHANUMERIC:
6276  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6277  if (is_value) {
6278  goto expect_alphanumeric;
6279  }
6280  if (l->scale == 0) {
6281  goto expect_alphanumeric;
6282  }
6283  goto non_integer_move;
6284  case CB_CATEGORY_NUMERIC:
6285  if (fdst->pic->scale < 0) {
6286  /* Check for PIC 9(n)P(m) */
6287  if (least_significant < -fdst->pic->scale) {
6288  goto value_mismatch;
6289  }
6290  } else if (fdst->pic->scale > fdst->pic->size) {
6291  /* Check for PIC P(n)9(m) */
6292  if (most_significant >= fdst->pic->size - fdst->pic->scale) {
6293  goto value_mismatch;
6294  }
6295  }
6296  break;
6297  case CB_CATEGORY_NUMERIC_EDITED:
6298  if (is_value) {
6299  goto expect_alphanumeric;
6300  }
6301 
6302  /* TODO */
6303  break;
6304  case CB_CATEGORY_ALPHABETIC:
6305  if (is_value) {
6306  goto expect_alphanumeric;
6307  }
6308  /* Coming from codegen */
6309  if (!suppress_warn) {
6310  goto invalid;
6311  }
6312 #if 1 /* RXWRXW - Initialize warn */
6313  if (warningopt) {
6314  cb_warning_x (loc, _("Numeric move to ALPHABETIC"));
6315  }
6316 #endif
6317  break;
6318  default:
6319  if (is_value) {
6320  goto expect_alphanumeric;
6321  }
6322  goto invalid;
6323  }
6324 
6325  /* Sign check */
6326  if (l->sign != 0 && !fdst->pic->have_sign) {
6327  if (is_value) {
6328  cb_error_x (loc, _("Data item not signed"));
6329  return -1;
6330  }
6331  if (cb_warn_constant) {
6332  cb_warning_x (loc, _("Ignoring sign"));
6333  }
6334  }
6335 
6336  /* Size check */
6337  if (fdst->flag_real_binary ||
6338  ((fdst->usage == CB_USAGE_COMP_5 ||
6339  fdst->usage == CB_USAGE_COMP_X ||
6340  fdst->usage == CB_USAGE_BINARY) &&
6341  fdst->pic->scale == 0)) {
6342  p = l->data;
6343  for (i = 0; i < l->size; i++) {
6344  if (l->data[i] != '0') {
6345  p = &l->data[i];
6346  break;
6347  }
6348  }
6349  i = l->size - i;
6350  switch (fdst->size) {
6351  case 1:
6352  if (i > 18) {
6353  goto numlit_overflow;
6354  }
6355  val = cb_get_long_long (src);
6356  if (fdst->pic->have_sign) {
6357  if (val < COB_S64_C(-128) ||
6358  val > COB_S64_C(127)) {
6359  goto numlit_overflow;
6360  }
6361  } else {
6362  if (val > COB_S64_C(255)) {
6363  goto numlit_overflow;
6364  }
6365  }
6366  break;
6367  case 2:
6368  if (i > 18) {
6369  goto numlit_overflow;
6370  }
6371  val = cb_get_long_long (src);
6372  if (fdst->pic->have_sign) {
6373  if (val < COB_S64_C(-32768) ||
6374  val > COB_S64_C(32767)) {
6375  goto numlit_overflow;
6376  }
6377  } else {
6378  if (val > COB_S64_C(65535)) {
6379  goto numlit_overflow;
6380  }
6381  }
6382  break;
6383  case 3:
6384  if (i > 18) {
6385  goto numlit_overflow;
6386  }
6387  val = cb_get_long_long (src);
6388  if (fdst->pic->have_sign) {
6389  if (val < COB_S64_C(-8388608) ||
6390  val > COB_S64_C(8388607)) {
6391  goto numlit_overflow;
6392  }
6393  } else {
6394  if (val > COB_S64_C(16777215)) {
6395  goto numlit_overflow;
6396  }
6397  }
6398  break;
6399  case 4:
6400  if (i > 18) {
6401  goto numlit_overflow;
6402  }
6403  val = cb_get_long_long (src);
6404  if (fdst->pic->have_sign) {
6405  if (val < COB_S64_C(-2147483648) ||
6406  val > COB_S64_C(2147483647)) {
6407  goto numlit_overflow;
6408  }
6409  } else {
6410  if (val > COB_S64_C(4294967295)) {
6411  goto numlit_overflow;
6412  }
6413  }
6414  break;
6415  case 5:
6416  if (i > 18) {
6417  goto numlit_overflow;
6418  }
6419  val = cb_get_long_long (src);
6420  if (fdst->pic->have_sign) {
6421  if (val < COB_S64_C(-549755813888) ||
6422  val > COB_S64_C(549755813887)) {
6423  goto numlit_overflow;
6424  }
6425  } else {
6426  if (val > COB_S64_C(1099511627775)) {
6427  goto numlit_overflow;
6428  }
6429  }
6430  break;
6431  case 6:
6432  if (i > 18) {
6433  goto numlit_overflow;
6434  }
6435  val = cb_get_long_long (src);
6436  if (fdst->pic->have_sign) {
6437  if (val < COB_S64_C(-140737488355328) ||
6438  val > COB_S64_C(140737488355327)) {
6439  goto numlit_overflow;
6440  }
6441  } else {
6442  if (val > COB_S64_C(281474976710655)) {
6443  goto numlit_overflow;
6444  }
6445  }
6446  break;
6447  case 7:
6448  if (i > 18) {
6449  goto numlit_overflow;
6450  }
6451  val = cb_get_long_long (src);
6452  if (fdst->pic->have_sign) {
6453  if (val < COB_S64_C(-36028797018963968) ||
6454  val > COB_S64_C(36028797018963967)) {
6455  goto numlit_overflow;
6456  }
6457  } else {
6458  if (val > COB_S64_C(72057594037927935)) {
6459  goto numlit_overflow;
6460  }
6461  }
6462  break;
6463  default:
6464  if (fdst->pic->have_sign) {
6465  if (i < 19) {
6466  break;
6467  }
6468  if (i > 19) {
6469  goto numlit_overflow;
6470  }
6471  if (memcmp (p, "9223372036854775807", (size_t)19) > 0) {
6472  goto numlit_overflow;
6473  }
6474  } else {
6475  if (i < 20) {
6476  break;
6477  }
6478  if (i > 20) {
6479  goto numlit_overflow;
6480  }
6481  if (memcmp (p, "18446744073709551615", (size_t)20) > 0) {
6482  goto numlit_overflow;
6483  }
6484  }
6485  break;
6486  }
6487  return 0;
6488  }
6489  if (least_significant < -fdst->pic->scale) {
6490  goto size_overflow;
6491  }
6492  if (fdst->pic->scale > 0) {
6493  size = fdst->pic->digits - fdst->pic->scale;
6494  } else {
6495  size = fdst->pic->digits;
6496  }
6497  if (most_significant >= size) {
6498  goto size_overflow;
6499  }
6500  } else {
6501  /* Alphanumeric literal */
6502 
6503  /* Value check */
6504  switch (CB_TREE_CATEGORY (dst)) {
6505  case CB_CATEGORY_ALPHABETIC:
6506  for (i = 0; i < l->size; i++) {
6507  if (!isalpha (l->data[i]) &&
6508  l->data[i] != ' ') {
6509  goto value_mismatch;
6510  }
6511  }
6512  break;
6513  case CB_CATEGORY_NUMERIC:
6514  goto expect_numeric;
6515  case CB_CATEGORY_NUMERIC_EDITED:
6516  if (!is_value) {
6517  goto expect_numeric;
6518  }
6519 
6520  /* TODO: validate the value */
6521  break;
6522  default:
6523  break;
6524  }
6525 
6526  /* Size check */
6527  size = cb_field_size (dst);
6528  if (size > 0 && (int)l->size > size) {
6529  goto size_overflow;
6530  }
6531  }
6532  break;
6533  case CB_TAG_FIELD:
6534  case CB_TAG_REFERENCE:
6535  if (CB_REFERENCE_P(src) &&
6536  CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
6537  break;
6538  }
6539  if (CB_REFERENCE_P(src) &&
6540  CB_FILE_P(CB_REFERENCE(src)->value)) {
6541  goto invalid;
6542  }
6543  fsrc = CB_FIELD_PTR (src);
6544  size = cb_field_size (src);
6545  if (size < 0) {
6546  size = fsrc->size;
6547  }
6548 
6549  /* Check basic overlapping */
6550  overlapping = cb_check_overlapping (src, dst, fsrc, fdst);
6551 
6552  /* Non-elementary move */
6553  if (fsrc->children || fdst->children) {
6554  if (size > fdst->size) {
6555  goto size_overflow_1;
6556  }
6557  break;
6558  }
6559 
6560  /* Elementary move */
6561  switch (CB_TREE_CATEGORY (src)) {
6562  case CB_CATEGORY_ALPHANUMERIC:
6563  switch (CB_TREE_CATEGORY (dst)) {
6564  case CB_CATEGORY_NUMERIC:
6565  case CB_CATEGORY_NUMERIC_EDITED:
6566  if (size > (int)fdst->pic->digits) {
6567  goto size_overflow_2;
6568  }
6569  break;
6570  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6571  if (size > count_pic_alphanumeric_edited (fdst)) {
6572  goto size_overflow_1;
6573  }
6574  break;
6575  default:
6576  if (size > fdst->size) {
6577  goto size_overflow_1;
6578  }
6579  break;
6580  }
6581  break;
6582  case CB_CATEGORY_ALPHABETIC:
6583  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6584  switch (CB_TREE_CATEGORY (dst)) {
6585  case CB_CATEGORY_NUMERIC:
6586  case CB_CATEGORY_NUMERIC_EDITED:
6587  goto invalid;
6588  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6589  if (size > count_pic_alphanumeric_edited(fdst)) {
6590  goto size_overflow_1;
6591  }
6592  break;
6593  default:
6594  if (size > fdst->size) {
6595  goto size_overflow_1;
6596  }
6597  break;
6598  }
6599  break;
6600  case CB_CATEGORY_NUMERIC:
6601  case CB_CATEGORY_NUMERIC_EDITED:
6602  switch (CB_TREE_CATEGORY (dst)) {
6603  case CB_CATEGORY_ALPHABETIC:
6604  goto invalid;
6605  case CB_CATEGORY_ALPHANUMERIC_EDITED:
6606  is_numeric_edited = 1;
6607  /* Drop through */
6608  case CB_CATEGORY_ALPHANUMERIC:
6609  if (!fsrc->pic) {
6610  return -1;
6611  }
6612  if (is_numeric_edited) {
6613  dst_size_mod = count_pic_alphanumeric_edited (fdst);
6614  } else {
6615  dst_size_mod = fdst->size;
6616  }
6617  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
6618  fsrc->pic->scale > 0) {
6619  goto non_integer_move;
6620  }
6621  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC &&
6622  (int)fsrc->pic->digits > dst_size_mod) {
6623  goto size_overflow_2;
6624  }
6625  if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC_EDITED &&
6626  fsrc->size > dst_size_mod) {
6627  goto size_overflow_1;
6628  }
6629  break;
6630  default:
6631  if (!fsrc->pic) {
6632  return -1;
6633  }
6634  if (!fdst->pic) {
6635  return -1;
6636  }
6637  src_scale_mod = fsrc->pic->scale < 0 ?
6638  0 : fsrc->pic->scale;
6639  dst_scale_mod = fdst->pic->scale < 0 ?
6640  0 : fdst->pic->scale;
6641  if (fsrc->pic->digits - src_scale_mod >
6642  fdst->pic->digits - dst_scale_mod ||
6643  src_scale_mod > dst_scale_mod) {
6644  goto size_overflow_2;
6645  }
6646  break;
6647  }
6648  break;
6649  default:
6650  cb_error_x (loc, _("Invalid source for MOVE"));
6651  return -1;
6652  }
6653  break;
6654  case CB_TAG_INTEGER:
6655  case CB_TAG_BINARY_OP:
6656  case CB_TAG_INTRINSIC:
6657  case CB_TAG_FUNCALL:
6658  /* TODO: check this */
6659  break;
6660  default:
6661  cobc_abort_pr (_("Unexpected tree tag %d"),
6662  (int)CB_TREE_TAG (src));
6663  COBC_ABORT ();
6664  }
6665  return 0;
6666 
6667 invalid:
6668  if (is_value) {
6669  cb_error_x (loc, _("Invalid VALUE clause"));
6670  } else {
6671  cb_error_x (loc, _("Invalid MOVE statement"));
6672  }
6673  return -1;
6674 
6675 numlit_overflow:
6676  if (is_value) {
6677  cb_error_x (loc, _("Invalid VALUE clause - literal exceeds data size"));
6678  return -1;
6679  }
6680  if (cb_warn_constant && !suppress_warn) {
6681  cb_warning_x (loc, _("Numeric literal exceeds data size"));
6682  }
6683  return 0;
6684 
6685 non_integer_move:
6686  if (cb_move_noninteger_to_alphanumeric == CB_ERROR) {
6687  goto invalid;
6688  }
6689  if (!suppress_warn) {
6690  cb_warning_x (loc, _("MOVE of non-integer to alphanumeric"));
6691  }
6692  return 0;
6693 
6694 expect_numeric:
6695  move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
6696  _("Numeric value is expected"));
6697  return 0;
6698 
6699 expect_alphanumeric:
6700  move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
6701  _("Alphanumeric value is expected"));
6702  return 0;
6703 
6704 value_mismatch:
6705  move_warning (src, dst, is_value, cb_warn_constant, 0,
6706  _("Value does not fit the picture string"));
6707  return 0;
6708 
6709 size_overflow:
6710  move_warning (src, dst, is_value, cb_warn_constant, 0,
6711  _("Value size exceeds data size"));
6712  return 0;
6713 
6714 size_overflow_1:
6715  move_warning (src, dst, is_value, cb_warn_truncate, 1,
6716  _("Sending field larger than receiving field"));
6717  return 0;
6718 
6719 size_overflow_2:
6720  move_warning (src, dst, is_value, cb_warn_truncate, 1,
6721  _("Some digits may be truncated"));
6722  return 0;
6723 }
6724 
6725 static cb_tree
6726 cb_build_memset (cb_tree x, const int c)
6727 {
6728  int size = cb_field_size (x);
6729 
6730  if (size == 1) {
6731  return CB_BUILD_FUNCALL_2 ("$E", x, cb_int (c));
6732  }
6733  return CB_BUILD_FUNCALL_3 ("memset",
6734  CB_BUILD_CAST_ADDRESS (x),
6735  cb_int (c), CB_BUILD_CAST_LENGTH (x));
6736 }
6737 
6738 static cb_tree
6739 cb_build_move_copy (cb_tree src, cb_tree dst)
6740 {
6741  int size;
6742 
6743  size = cb_field_size (dst);
6744  if (size == 1) {
6745  return CB_BUILD_FUNCALL_2 ("$F", dst, src);
6746  }
6747  if (overlapping
6748  || CB_FIELD_PTR (src)->storage == CB_STORAGE_LINKAGE
6749  || CB_FIELD_PTR (dst)->storage == CB_STORAGE_LINKAGE
6750  || CB_FIELD_PTR (src)->flag_item_based
6751  || CB_FIELD_PTR (dst)->flag_item_based) {
6752  overlapping = 0;
6753  return CB_BUILD_FUNCALL_3 ("memmove",
6754  CB_BUILD_CAST_ADDRESS (dst),
6755  CB_BUILD_CAST_ADDRESS (src),
6756  CB_BUILD_CAST_LENGTH (dst));
6757  } else {
6758  return CB_BUILD_FUNCALL_3 ("memcpy",
6759  CB_BUILD_CAST_ADDRESS (dst),
6760  CB_BUILD_CAST_ADDRESS (src),
6761  CB_BUILD_CAST_LENGTH (dst));
6762  }
6763 }
6764 
6765 static cb_tree
6766 cb_build_move_num_zero (cb_tree x)
6767 {
6768  struct cb_field *f;
6769 
6770  f = CB_FIELD_PTR (x);
6771  switch (f->usage) {
6772  case CB_USAGE_BINARY:
6773  case CB_USAGE_COMP_5:
6774  case CB_USAGE_COMP_X:
6775  if (f->flag_binary_swap) {
6776  return cb_build_memset (x, 0);
6777  }
6778  switch (f->size) {
6779 #ifdef COB_NON_ALIGNED
6780  case 1:
6781  return cb_build_assign (x, cb_int0);
6782  case 2:
6783 #ifdef COB_SHORT_BORK
6784  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6785  (f->offset % 4 == 0)) {
6786  return cb_build_assign (x, cb_int0);
6787  }
6788  break;
6789 #endif
6790  case 4:
6791  case 8:
6792  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
6793  (f->offset % f->size == 0)) {
6794  return cb_build_assign (x, cb_int0);
6795  }
6796  break;
6797 #else
6798  case 1:
6799  case 2:
6800  case 4:
6801  case 8:
6802  return cb_build_assign (x, cb_int0);
6803 #endif
6804  default:
6805  break;
6806  }
6807  return cb_build_memset (x, 0);
6808  case CB_USAGE_DISPLAY:
6809  if (!cb_ebcdic_sign) {
6810  return cb_build_memset (x, '0');
6811  }
6812  if (f->pic && !f->pic->have_sign) {
6813  return cb_build_memset (x, '0');
6814  }
6815  break;
6816  case CB_USAGE_PACKED:
6817  return CB_BUILD_FUNCALL_1 ("cob_set_packed_zero", x);
6818  case CB_USAGE_COMP_6:
6819  return cb_build_memset (x, 0);
6820  default:
6821  break;
6822  }
6823  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6824 }
6825 
6826 static cb_tree
6827 cb_build_move_space (cb_tree x)
6828 {
6829  switch (CB_TREE_CATEGORY (x)) {
6830  case CB_CATEGORY_NUMERIC:
6831  case CB_CATEGORY_ALPHABETIC:
6832  case CB_CATEGORY_ALPHANUMERIC:
6833  if (!CB_FIELD_PTR (x)->flag_any_length) {
6834  return cb_build_memset (x, ' ');
6835  }
6836  /* Fall through */
6837  default:
6838  return CB_BUILD_FUNCALL_2 ("cob_move", cb_space, x);
6839  }
6840 }
6841 
6842 static cb_tree
6843 cb_build_move_zero (cb_tree x)
6844 {
6845  switch (CB_TREE_CATEGORY (x)) {
6846  case CB_CATEGORY_NUMERIC:
6847  if (CB_FIELD_PTR (x)->flag_blank_zero) {
6848  return cb_build_move_space (x);
6849  } else if (CB_FIELD_PTR (x)->flag_sign_separate) {
6850  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6851  } else {
6852  return cb_build_move_num_zero (x);
6853  }
6854  case CB_CATEGORY_ALPHABETIC:
6855  case CB_CATEGORY_ALPHANUMERIC:
6856  if (!CB_FIELD_PTR (x)->flag_any_length) {
6857  return cb_build_memset (x, '0');
6858  }
6859  /* Fall through */
6860  default:
6861  return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
6862  }
6863 }
6864 
6865 static cb_tree
6866 cb_build_move_high (cb_tree x)
6867 {
6868  switch (CB_TREE_CATEGORY (x)) {
6869  case CB_CATEGORY_NUMERIC:
6870  case CB_CATEGORY_ALPHABETIC:
6871  case CB_CATEGORY_ALPHANUMERIC:
6872  if (CB_FIELD_PTR (x)->flag_any_length) {
6873  return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
6874  }
6875  if (cb_high == cb_norm_high) {
6876  return cb_build_memset (x, 255);
6877  }
6878  /* Fall through */
6879  default:
6880  return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
6881  }
6882 }
6883 
6884 static cb_tree
6885 cb_build_move_low (cb_tree x)
6886 {
6887  switch (CB_TREE_CATEGORY (x)) {
6888  case CB_CATEGORY_NUMERIC:
6889  case CB_CATEGORY_ALPHABETIC:
6890  case CB_CATEGORY_ALPHANUMERIC:
6891  if (CB_FIELD_PTR (x)->flag_any_length) {
6892  return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
6893  }
6894  if (cb_low == cb_norm_low) {
6895  return cb_build_memset (x, 0);
6896  }
6897  /* Fall through */
6898  default:
6899  return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
6900  }
6901 }
6902 
6903 static cb_tree
6904 cb_build_move_quote (cb_tree x)
6905 {
6906  switch (CB_TREE_CATEGORY (x)) {
6907  case CB_CATEGORY_NUMERIC:
6908  case CB_CATEGORY_ALPHABETIC:
6909  case CB_CATEGORY_ALPHANUMERIC:
6910  if (!CB_FIELD_PTR (x)->flag_any_length) {
6911  return cb_build_memset (x, cb_flag_apostrophe ? '\'' : '"');
6912  }
6913  /* Fall through */
6914  default:
6915  return CB_BUILD_FUNCALL_2 ("cob_move", cb_quote, x);
6916  }
6917 }
6918 
6919 #ifdef COB_EBCDIC_MACHINE
6920 static void
6921 cob_put_sign_ascii (unsigned char *p)
6922 {
6923  switch (*p) {
6924  case '0':
6925  *p = (unsigned char)'p';
6926  return;
6927  case '1':
6928  *p = (unsigned char)'q';
6929  return;
6930  case '2':
6931  *p = (unsigned char)'r';
6932  return;
6933  case '3':
6934  *p = (unsigned char)'s';
6935  return;
6936  case '4':
6937  *p = (unsigned char)'t';
6938  return;
6939  case '5':
6940  *p = (unsigned char)'u';
6941  return;
6942  case '6':
6943  *p = (unsigned char)'v';
6944  return;
6945  case '7':
6946  *p = (unsigned char)'w';
6947  return;
6948  case '8':
6949  *p = (unsigned char)'x';
6950  return;
6951  case '9':
6952  *p = (unsigned char)'y';
6953  return;
6954  }
6955 }
6956 #endif
6957 
6958 static void
6959 cob_put_sign_ebcdic (unsigned char *p, const int sign)
6960 {
6961  if (sign < 0) {
6962  switch (*p) {
6963  case '0':
6964  *p = (unsigned char)'}';
6965  return;
6966  case '1':
6967  *p = (unsigned char)'J';
6968  return;
6969  case '2':
6970  *p = (unsigned char)'K';
6971  return;
6972  case '3':
6973  *p = (unsigned char)'L';
6974  return;
6975  case '4':
6976  *p = (unsigned char)'M';
6977  return;
6978  case '5':
6979  *p = (unsigned char)'N';
6980  return;
6981  case '6':
6982  *p = (unsigned char)'O';
6983  return;
6984  case '7':
6985  *p = (unsigned char)'P';
6986  return;
6987  case '8':
6988  *p = (unsigned char)'Q';
6989  return;
6990  case '9':
6991  *p = (unsigned char)'R';
6992  return;
6993  default:
6994  /* What to do here */
6995  *p = (unsigned char)'}';
6996  return;
6997  }
6998  }
6999  switch (*p) {
7000  case '0':
7001  *p = (unsigned char)'{';
7002  return;
7003  case '1':
7004  *p = (unsigned char)'A';
7005  return;
7006  case '2':
7007  *p = (unsigned char)'B';
7008  return;
7009  case '3':
7010  *p = (unsigned char)'C';
7011  return;
7012  case '4':
7013  *p = (unsigned char)'D';
7014  return;
7015  case '5':
7016  *p = (unsigned char)'E';
7017  return;
7018  case '6':
7019  *p = (unsigned char)'F';
7020  return;
7021  case '7':
7022  *p = (unsigned char)'G';
7023  return;
7024  case '8':
7025  *p = (unsigned char)'H';
7026  return;
7027  case '9':
7028  *p = (unsigned char)'I';
7029  return;
7030  default:
7031  /* What to do here */
7032  *p = (unsigned char)'{';
7033  return;
7034  }
7035 }
7036 
7037 static cb_tree
7038 cb_build_move_literal (cb_tree src, cb_tree dst)
7039 {
7040  struct cb_literal *l;
7041  struct cb_field *f;
7042  unsigned char *buff;
7043  unsigned char *p;
7044  enum cb_category cat;
7045  int i;
7046  int diff;
7047  int val;
7048  int n;
7049  unsigned char bbyte;
7050 
7051  l = CB_LITERAL (src);
7052  f = CB_FIELD_PTR (dst);
7053  cat = CB_TREE_CATEGORY (dst);
7054 
7055  if (l->all) {
7056  if (cat == CB_CATEGORY_NUMERIC ||
7057  cat == CB_CATEGORY_NUMERIC_EDITED) {
7058  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7059  }
7060  if (l->size == 1) {
7061  return CB_BUILD_FUNCALL_3 ("memset",
7062  CB_BUILD_CAST_ADDRESS (dst),
7063  cb_int (l->data[0]),
7064  CB_BUILD_CAST_LENGTH (dst));
7065  }
7066  bbyte = l->data[0];
7067  for (i = 0; i < (int)l->size; i++) {
7068  if (bbyte != l->data[i]) {
7069  break;
7070  }
7071  bbyte = l->data[i];
7072  }
7073  if (i == (int)l->size) {
7074  return CB_BUILD_FUNCALL_3 ("memset",
7075  CB_BUILD_CAST_ADDRESS (dst),
7076  cb_int (l->data[0]),
7077  CB_BUILD_CAST_LENGTH (dst));
7078  }
7079  if (f->size > 128) {
7080  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7081  }
7082  buff = cobc_parse_malloc ((size_t)f->size);
7083  for (i = 0; i < f->size; i++) {
7084  buff[i] = l->data[i % l->size];
7085  }
7086  return CB_BUILD_FUNCALL_3 ("memcpy",
7087  CB_BUILD_CAST_ADDRESS (dst),
7088  cb_build_string (buff, (size_t)f->size),
7089  CB_BUILD_CAST_LENGTH (dst));
7090  }
7091 
7092  if (cat == CB_CATEGORY_NUMERIC_EDITED) {
7093  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7094  }
7095 
7096  if ((cat == CB_CATEGORY_NUMERIC &&
7097  f->usage == CB_USAGE_DISPLAY &&
7098  f->pic->scale == l->scale &&
7099  !f->flag_sign_leading && !f->flag_sign_separate &&
7100  !f->flag_blank_zero) ||
7101  ((cat == CB_CATEGORY_ALPHABETIC ||
7102  cat == CB_CATEGORY_ALPHANUMERIC) &&
7103  f->size < (int) (l->size + 16) &&
7104  !cb_field_variable_size (f))) {
7105  buff = cobc_parse_malloc ((size_t)f->size);
7106  diff = (int) (f->size - l->size);
7107  if (cat == CB_CATEGORY_NUMERIC) {
7108  if (diff <= 0) {
7109  memcpy (buff, l->data - diff, (size_t)f->size);
7110  } else {
7111  memset (buff, '0', (size_t)diff);
7112  memcpy (buff + diff, l->data, (size_t)l->size);
7113  }
7114  /* Check all zeros */
7115  n = 0;
7116  for (p = buff; p < buff + f->size; p++) {
7117  if (*p != '0') {
7118  n = 1;
7119  break;
7120  }
7121  }
7122  if (f->pic->have_sign) {
7123  p = &buff[f->size - 1];
7124  if (!n) {
7125  /* Zeros */
7126  /* EBCDIC - store sign otherwise nothing */
7127  if (cb_ebcdic_sign) {
7128  cob_put_sign_ebcdic (p, 1);
7129  }
7130  } else if (cb_ebcdic_sign) {
7131  cob_put_sign_ebcdic (p, l->sign);
7132  } else if (l->sign < 0) {
7133 #ifdef COB_EBCDIC_MACHINE
7134  cob_put_sign_ascii (p);
7135 #else
7136  *p += 0x40;
7137 #endif
7138  }
7139  }
7140  } else {
7141  if (f->flag_justified) {
7142  if (diff <= 0) {
7143  memcpy (buff, l->data - diff, (size_t)f->size);
7144  } else {
7145  memset (buff, ' ', (size_t)diff);
7146  memcpy (buff + diff, l->data, (size_t)l->size);
7147  }
7148  } else {
7149  if (diff <= 0) {
7150  memcpy (buff, l->data, (size_t)f->size);
7151  } else {
7152  memcpy (buff, l->data, (size_t)l->size);
7153  memset (buff + l->size, ' ', (size_t)diff);
7154  }
7155  }
7156  }
7157  bbyte = *buff;
7158  if (f->size == 1) {
7159  cobc_parse_free (buff);
7160  return CB_BUILD_FUNCALL_2 ("$E", dst, cb_int (bbyte));
7161  }
7162  for (i = 0; i < f->size; i++) {
7163  if (bbyte != buff[i]) {
7164  break;
7165  }
7166  }
7167  if (i == f->size) {
7168  cobc_parse_free (buff);
7169  return CB_BUILD_FUNCALL_3 ("memset",
7170  CB_BUILD_CAST_ADDRESS (dst),
7171  cb_int (bbyte),
7172  CB_BUILD_CAST_LENGTH (dst));
7173  }
7174  return CB_BUILD_FUNCALL_3 ("memcpy",
7175  CB_BUILD_CAST_ADDRESS (dst),
7176  cb_build_string (buff, (size_t)f->size),
7177  CB_BUILD_CAST_LENGTH (dst));
7178  }
7179 
7180  if ((f->usage == CB_USAGE_BINARY ||
7181  f->usage == CB_USAGE_COMP_5 ||
7182  f->usage == CB_USAGE_COMP_X) &&
7183  cb_fits_int (src) && f->size <= 8) {
7184  val = cb_get_int (src);
7185  n = f->pic->scale - l->scale;
7186  if ((l->size + n) > 9) {
7187  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7188  }
7189  for (; n > 0; n--) {
7190  val *= 10;
7191  }
7192  for (; n < 0; n++) {
7193  val /= 10;
7194  }
7195  if (val == 0) {
7196  return cb_build_move_num_zero (dst);
7197  }
7198  if (val < 0 && !f->pic->have_sign) {
7199  val = -val;
7200  }
7201  if (f->size == 1) {
7202  return cb_build_assign (dst, cb_int (val));
7203  }
7204  if (f->flag_binary_swap) {
7205  i = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0));
7206  optimize_defs[bin_set_funcs[i].optim_val] = 1;
7207  return CB_BUILD_FUNCALL_2 (bin_set_funcs[i].optim_name,
7208  CB_BUILD_CAST_ADDRESS (dst),
7209  cb_int (val));
7210  }
7211  switch (f->size) {
7212  case 2:
7213 #ifdef COB_SHORT_BORK
7214  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
7215  (f->offset % 4 == 0)) {
7216  return cb_build_assign (dst, cb_int (val));
7217  }
7218  break;
7219 #endif
7220  case 4:
7221  case 8:
7222 #ifdef COB_NON_ALIGNED
7223  if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
7224  (f->offset % f->size == 0)) {
7225  return cb_build_assign (dst, cb_int (val));
7226  }
7227  break;
7228 #else
7229  return cb_build_assign (dst, cb_int (val));
7230 #endif
7231  default:
7232  break;
7233  }
7234  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7235  }
7236 
7237  if ((f->usage == CB_USAGE_PACKED || f->usage == CB_USAGE_COMP_6) &&
7238  cb_fits_int (src)) {
7239  if (f->pic->scale < 0) {
7240  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7241  }
7242  val = cb_get_int (src);
7243  n = f->pic->scale - l->scale;
7244  if ((l->size + n) > 9) {
7245  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7246  }
7247  for (; n > 0; n--) {
7248  val *= 10;
7249  }
7250  for (; n < 0; n++) {
7251  val /= 10;
7252  }
7253  if (val == 0) {
7254  return cb_build_move_num_zero (dst);
7255  }
7256  if (val < 0 && !f->pic->have_sign) {
7257  val = -val;
7258  }
7259 #if 1 /* RXWRXW - Set packed */
7260  return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
7261  cb_int (val));
7262 #else
7263  return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
7264  cb_build_cast_llint (src));
7265 #endif
7266  }
7267  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7268 }
7269 
7270 static cb_tree
7271 cb_build_move_field (cb_tree src, cb_tree dst)
7272 {
7273  struct cb_field *src_f;
7274  struct cb_field *dst_f;
7275  int src_size;
7276  int dst_size;
7277 
7278  src_f = CB_FIELD_PTR (src);
7279  src_size = cb_field_size (src);
7280  dst_f = CB_FIELD_PTR (dst);
7281  dst_size = cb_field_size (dst);
7282 
7283  if (dst_f->flag_any_length || src_f->flag_any_length) {
7284  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7285  }
7286  if (src_size > 0 && dst_size > 0 && src_size >= dst_size &&
7287  !cb_field_variable_size (src_f) &&
7288  !cb_field_variable_size (dst_f)) {
7289  switch (CB_TREE_CATEGORY (src)) {
7290  case CB_CATEGORY_ALPHABETIC:
7291  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC ||
7292  CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
7293  if (dst_f->flag_justified == 0) {
7294  return cb_build_move_copy (src, dst);
7295  }
7296  }
7297  break;
7298  case CB_CATEGORY_ALPHANUMERIC:
7299  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
7300  if (dst_f->flag_justified == 0) {
7301  return cb_build_move_copy (src, dst);
7302  }
7303  }
7304  break;
7305  case CB_CATEGORY_NUMERIC:
7306  if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC &&
7307  src_f->usage == dst_f->usage &&
7308  src_f->pic->size == dst_f->pic->size &&
7309  src_f->pic->digits == dst_f->pic->digits &&
7310  src_f->pic->scale == dst_f->pic->scale &&
7311  src_f->pic->have_sign == dst_f->pic->have_sign &&
7312  src_f->flag_binary_swap == dst_f->flag_binary_swap &&
7313  src_f->flag_sign_leading == dst_f->flag_sign_leading &&
7314  src_f->flag_sign_separate == dst_f->flag_sign_separate) {
7315  return cb_build_move_copy (src, dst);
7316  } else if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC
7317  && src_f->usage == CB_USAGE_DISPLAY
7318  && src_f->pic->have_sign == 0
7319  && !src_f->flag_sign_leading
7320  && !src_f->flag_sign_separate) {
7321  return cb_build_move_copy (src, dst);
7322  }
7323  break;
7324  default:
7325  break;
7326  }
7327  }
7328 
7329  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7330 }
7331 
7332 cb_tree
7333 cb_build_move (cb_tree src, cb_tree dst)
7334 {
7335  struct cb_reference *x;
7336 
7337  if (src == cb_error_node || dst == cb_error_node) {
7338  return cb_error_node;
7339  }
7340 
7341  if (validate_move (src, dst, 0) < 0) {
7342  return cb_error_node;
7343  }
7344 
7345 #if 0 /* Flag receiving */
7346  if (CB_REFERENCE_P (src)) {
7347  CB_REFERENCE (src)->flag_receiving = 0;
7348  }
7349 #endif
7350 
7351  if (CB_REFERENCE_P (dst)) {
7352  /* Clone reference */
7353  x = cobc_parse_malloc (sizeof(struct cb_reference));
7354  *x = *CB_REFERENCE (dst);
7355  x->flag_receiving = 1;
7356  dst = CB_TREE (x);
7357  }
7358 
7359  if ((src == cb_space || src == cb_low ||
7360  src == cb_high || src == cb_quote) &&
7361  (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC ||
7362  CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED)) {
7363  src = cb_zero;
7364  }
7365 
7366  if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER ||
7367  CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
7368  return cb_build_assign (dst, src);
7369  }
7370 
7371  if (CB_REFERENCE_P (src) &&
7372  CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
7373  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7374  }
7375  if (CB_INDEX_P (dst)) {
7376  if (src == cb_null) {
7377  return cb_build_assign (dst, cb_zero);
7378  }
7379  return cb_build_assign (dst, src);
7380  }
7381 
7382  if (CB_INDEX_P (src)) {
7383  return CB_BUILD_FUNCALL_2 ("cob_set_int", dst,
7384  cb_build_cast_int (src));
7385  }
7386 
7387  if (CB_INTRINSIC_P (src) || CB_INTRINSIC_P (dst)) {
7388  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7389  }
7390 
7391  if (CB_REFERENCE_P (src) && CB_REFERENCE (src)->check) {
7392  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7393  }
7394  if (CB_REFERENCE_P (dst) && CB_REFERENCE (dst)->check) {
7395  return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
7396  }
7397 
7398  /* Output optimal code */
7399  if (src == cb_zero) {
7400  return cb_build_move_zero (dst);
7401  } else if (src == cb_space) {
7402  return cb_build_move_space (dst);
7403  } else if (src == cb_high) {
7404  return cb_build_move_high (dst);
7405  } else if (src == cb_low) {
7406  return cb_build_move_low (dst);
7407  } else if (src == cb_quote) {
7408  return cb_build_move_quote (dst);
7409  } else if (CB_LITERAL_P (src)) {
7410  return cb_build_move_literal (src, dst);
7411  }
7412  return cb_build_move_field (src, dst);
7413 }
7414 
7415 void
7416 cb_emit_move (cb_tree src, cb_tree dsts)
7417 {
7418  cb_tree l;
7419  cb_tree x;
7420  cb_tree m;
7421  unsigned int tempval;
7422 
7423  if (cb_validate_one (src)) {
7424  return;
7425  }
7426  if (cb_validate_list (dsts)) {
7427  return;
7428  }
7429 
7430  cb_check_data_incompat (src);
7431 
7432  tempval = 0;
7433  if (cb_list_length (dsts) > 1) {
7434  if (CB_INTRINSIC_P (src) || (CB_REFERENCE_P (src) &&
7435  (CB_REFERENCE (src)->subs || CB_REFERENCE (src)->offset))) {
7436  tempval = 1;
7437  cb_emit (CB_BUILD_FUNCALL_1 ("cob_put_indirect_field",
7438  src));
7439  }
7440  }
7441 
7442  for (l = dsts; l; l = CB_CHAIN (l)) {
7443  x = CB_VALUE (l);
7444  if (CB_LITERAL_P (x) || CB_CONST_P (x)) {
7445  cb_error_x (CB_TREE (current_statement),
7446  _("Invalid MOVE target - %s"), cb_name (x));
7447  continue;
7448  }
7449  if (!tempval) {
7450  m = cb_build_move (src, x);
7451  } else {
7452  m = CB_BUILD_FUNCALL_1 ("cob_get_indirect_field", x);
7453  }
7454  cb_emit (m);
7455  }
7456 }
7457 
7458 /* OPEN statement */
7459 
7460 void
7461 cb_emit_open (cb_tree file, cb_tree mode, cb_tree sharing)
7462 {
7463  struct cb_file *f;
7464 
7465  if (file == cb_error_node) {
7466  return;
7467  }
7468  file = cb_ref (file);
7469  if (file == cb_error_node) {
7470  return;
7471  }
7472  current_statement->file = file;
7473  f = CB_FILE (file);
7474 
7475  if (f->organization == COB_ORG_SORT) {
7476  cb_error_x (CB_TREE (current_statement),
7477  _("%s not allowed on %s files"), "OPEN", "SORT");
7478  return;
7479  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
7480  mode == cb_int (COB_OPEN_I_O)) {
7481  cb_error_x (CB_TREE (current_statement),
7482  _("%s not allowed on %s files"), "OPEN I-O", "LINE SEQUENTIAL");
7483  return;
7484  }
7485  if (sharing == NULL) {
7486  if (f->sharing) {
7487  sharing = f->sharing;
7488  } else {
7489  sharing = cb_int0;
7490  }
7491  }
7492 
7493  cb_emit (CB_BUILD_FUNCALL_4 ("cob_open", file, mode,
7494  sharing, f->file_status));
7495 
7496  /* Check for file debugging */
7497  if (current_program->flag_debugging &&
7498  !current_statement->flag_in_debug &&
7499  f->flag_fl_debug) {
7500  cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
7501  cb_emit (cb_build_move (cb_space, cb_debug_contents));
7502  cb_emit (cb_build_debug_call (f->debug_section));
7503  }
7504 }
7505 
7506 /* PERFORM statement */
7507 
7508 void
7509 cb_emit_perform (cb_tree perform, cb_tree body)
7510 {
7511  if (perform == cb_error_node) {
7512  return;
7513  }
7514  if (current_program->flag_debugging &&
7515  !current_statement->flag_in_debug && CB_PAIR_P (body)) {
7516  cb_emit (cb_build_debug (cb_debug_contents, "PERFORM LOOP", NULL));
7517  }
7518  CB_PERFORM (perform)->body = body;
7519  cb_emit (perform);
7520 }
7521 
7522 cb_tree
7523 cb_build_perform_once (cb_tree body)
7524 {
7525  cb_tree x;
7526 
7527  if (body == cb_error_node) {
7528  return cb_error_node;
7529  }
7530  x = cb_build_perform (CB_PERFORM_ONCE);
7531  CB_PERFORM (x)->body = body;
7532  return x;
7533 }
7534 
7535 cb_tree
7536 cb_build_perform_times (cb_tree times)
7537 {
7538  cb_tree x;
7539 
7540  if (cb_check_integer_value (times) == cb_error_node) {
7541  return cb_error_node;
7542  }
7543 
7544  x = cb_build_perform (CB_PERFORM_TIMES);
7545  CB_PERFORM (x)->data = times;
7546  return x;
7547 }
7548 
7549 cb_tree
7550 cb_build_perform_until (cb_tree condition, cb_tree varying)
7551 {
7552  cb_tree x;
7553 
7554  x = cb_build_perform (CB_PERFORM_UNTIL);
7555  CB_PERFORM (x)->test = condition;
7556  CB_PERFORM (x)->varying = varying;
7557  return x;
7558 }
7559 
7560 cb_tree
7561 cb_build_perform_forever (cb_tree body)
7562 {
7563  cb_tree x;
7564 
7565  if (body == cb_error_node) {
7566  return cb_error_node;
7567  }
7568  x = cb_build_perform (CB_PERFORM_FOREVER);
7569  CB_PERFORM (x)->body = body;
7570  return x;
7571 }
7572 
7573 cb_tree
7574 cb_build_perform_exit (struct cb_label *label)
7575 {
7576  cb_tree x;
7577 
7578  x = cb_build_perform (CB_PERFORM_EXIT);
7579  CB_PERFORM (x)->data = CB_TREE (label);
7580  return x;
7581 }
7582 
7583 /* READ statement */
7584 
7585 void
7586 cb_emit_read (cb_tree ref, cb_tree next, cb_tree into,
7587  cb_tree key, cb_tree lock_opts)
7588 {
7589  cb_tree file;
7590  cb_tree rec;
7591  cb_tree x;
7592  struct cb_file *f;
7593  int read_opts;
7594 
7595  read_opts = 0;
7596  if (lock_opts == cb_int1) {
7597  read_opts = COB_READ_LOCK;
7598  } else if (lock_opts == cb_int2) {
7599  read_opts = COB_READ_NO_LOCK;
7600  } else if (lock_opts == cb_int3) {
7601  read_opts = COB_READ_IGNORE_LOCK;
7602  } else if (lock_opts == cb_int4) {
7603  read_opts = COB_READ_WAIT_LOCK;
7604  }
7605  if (ref == cb_error_node) {
7606  return;
7607  }
7608  file = cb_ref (ref);
7609  if (file == cb_error_node) {
7610  return;
7611  }
7612  f = CB_FILE (file);
7613 
7614  rec = cb_build_field_reference (f->record, ref);
7615  if (f->organization == COB_ORG_SORT) {
7616  cb_error_x (CB_TREE (current_statement),
7617  _("%s not allowed on %s files"), "READ", "SORT");
7618  return;
7619  }
7620  if (next == cb_int1 || next == cb_int2 ||
7621  f->access_mode == COB_ACCESS_SEQUENTIAL) {
7622  /* READ NEXT/PREVIOUS */
7623  if (next == cb_int2) {
7624  switch (f->organization) {
7625  case COB_ORG_INDEXED:
7626  case COB_ORG_RELATIVE:
7627  break;
7628  default:
7629  cb_error_x (CB_TREE (current_statement),
7630  _("READ PREVIOUS not allowed for this file type"));
7631  return;
7632  }
7633  read_opts |= COB_READ_PREVIOUS;
7634  } else {
7635  read_opts |= COB_READ_NEXT;
7636  }
7637  if (key) {
7638  cb_warning (_("KEY ignored with sequential READ"));
7639  }
7640  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7641  f->file_status,
7642  cb_int (read_opts)));
7643  } else {
7644  /* READ */
7645  /* DYNAMIC with [NOT] AT END */
7646  if (f->access_mode == COB_ACCESS_DYNAMIC &&
7647  current_statement->handler_id == COB_EC_I_O_AT_END) {
7648  read_opts |= COB_READ_NEXT;
7649  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7650  f->file_status,
7651  cb_int (read_opts)));
7652  } else if (key || f->key) {
7653  cb_emit (CB_BUILD_FUNCALL_4 ("cob_read",
7654  file, key ? key : f->key,
7655  f->file_status, cb_int (read_opts)));
7656  } else {
7657  cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
7658  f->file_status,
7659  cb_int (read_opts)));
7660  }
7661  }
7662  if (into) {
7663  current_statement->handler3 = cb_build_move (rec, into);
7664  }
7665 
7666  /* Check for file debugging */
7667  if (current_program->flag_debugging &&
7668  !current_statement->flag_in_debug &&
7669  f->flag_fl_debug) {
7670  if (into) {
7671  current_statement->handler3 =
7672  CB_LIST_INIT (current_statement->handler3);
7673  }
7674  x = cb_build_debug (cb_debug_name, f->name, NULL);
7675  current_statement->handler3 =
7676  cb_list_add (current_statement->handler3, x);
7677  x = cb_build_move (rec, cb_debug_contents);
7678  current_statement->handler3 =
7679  cb_list_add (current_statement->handler3, x);
7680  x = cb_build_debug_call (f->debug_section);
7681  current_statement->handler3 =
7682  cb_list_add (current_statement->handler3, x);
7683  }
7684  current_statement->file = file;
7685 }
7686 
7687 /* READY TRACE statement */
7688 
7689 void
7690 cb_emit_ready_trace (void)
7691 {
7692  cb_emit (CB_BUILD_FUNCALL_0 ("cob_ready_trace"));
7693 }
7694 
7695 
7696 /* RESET TRACE statement */
7697 
7698 void
7699 cb_emit_reset_trace (void)
7700 {
7701  cb_emit (CB_BUILD_FUNCALL_0 ("cob_reset_trace"));
7702 }
7703 
7704 /* REWRITE statement */
7705 
7706 void
7707 cb_emit_rewrite (cb_tree record, cb_tree from, cb_tree lockopt)
7708 {
7709  cb_tree file;
7710  struct cb_file *f;
7711  int opts;
7712 
7713  if (cb_validate_one (record)) {
7714  return;
7715  }
7716  if (cb_validate_one (from)) {
7717  return;
7718  }
7719  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
7720  cb_error_x (CB_TREE (current_statement),
7721  _("%s requires a record name as subject"), "REWRITE");
7722  return;
7723  }
7724  if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
7725  cb_error_x (CB_TREE (current_statement),
7726  _("%s subject does not refer to a record name"), "REWRITE");
7727  return;
7728  }
7729 
7730  file = CB_TREE (CB_FIELD (cb_ref (record))->file);
7731  if (!file || file == cb_error_node) {
7732  return;
7733  }
7734  current_statement->file = file;
7735  f = CB_FILE (file);
7736  opts = 0;
7737 
7738  if (f->organization == COB_ORG_SORT) {
7739  cb_error_x (CB_TREE (current_statement),
7740  _("%s not allowed on %s files"), "REWRITE", "SORT");
7741  return;
7742  } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
7743  cb_error_x (CB_TREE (current_statement),
7744  _("%s not allowed on %s files"), "REWRITE", "LINE SEQUENTIAL");
7745  return;
7746  } else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
7747  (f->organization != COB_ORG_RELATIVE &&
7748  f->organization != COB_ORG_INDEXED)) {
7749  cb_error_x (CB_TREE(current_statement),
7750  _("INVALID KEY clause invalid with this file type"));
7751  return;
7752  } else if ((f->lock_mode & COB_LOCK_AUTOMATIC) && lockopt) {
7753  cb_error_x (CB_TREE (current_statement),
7754  _("LOCK clause invalid with file LOCK AUTOMATIC"));
7755  return;
7756  } else if (lockopt == cb_int1) {
7757  opts = COB_WRITE_LOCK;
7758  }
7759 
7760  if (from) {
7761  cb_emit (cb_build_move (from, record));
7762  }
7763 
7764  /* Check debugging on record name */
7765  if (current_program->flag_debugging &&
7766  !current_statement->flag_in_debug &&
7767  CB_FIELD_PTR (record)->flag_field_debug) {
7768  cb_emit (cb_build_debug (cb_debug_name,
7769  CB_FIELD_PTR (record)->name, NULL));
7770  cb_emit (cb_build_move (record, cb_debug_contents));
7771  cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
7772  }
7773  cb_emit (CB_BUILD_FUNCALL_4 ("cob_rewrite", file, record,
7774  cb_int (opts), f->file_status));
7775 }
7776 
7777 /* RELEASE statement */
7778 
7779 void
7780 cb_emit_release (cb_tree record, cb_tree from)
7781 {
7782  struct cb_field *f;
7783  cb_tree file;
7784 
7785  if (cb_validate_one (record)) {
7786  return;
7787  }
7788  if (cb_validate_one (from)) {
7789  return;
7790  }
7791  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
7792  cb_error_x (CB_TREE (current_statement),
7793  _("%s requires a record name as subject"), "RELEASE");
7794  return;
7795  }
7796  f = CB_FIELD_PTR (record);
7797  if (f->storage != CB_STORAGE_FILE) {
7798  cb_error_x (CB_TREE (current_statement),
7799  _("%s subject does not refer to a record name"), "RELEASE");
7800  return;
7801  }
7802  file = CB_TREE (f->file);
7803  if (CB_FILE (file)->organization != COB_ORG_SORT) {
7804  cb_error_x (CB_TREE (current_statement),
7805  _("RELEASE not allowed on this record item"));
7806  return;
7807  }
7808  current_statement->file = file;
7809  if (from) {
7810  cb_emit (cb_build_move (from, record));
7811  }
7812  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_release", file));
7813 }
7814 
7815 /* RETURN statement */
7816 
7817 void
7818 cb_emit_return (cb_tree ref, cb_tree into)
7819 {
7820  cb_tree file;
7821  cb_tree rec;
7822 
7823  if (cb_validate_one (ref)) {
7824  return;
7825  }
7826  if (cb_validate_one (into)) {
7827  return;
7828  }
7829  file = cb_ref (ref);
7830  if (file == cb_error_node) {
7831  return;
7832  }
7833  rec = cb_build_field_reference (CB_FILE (file)->record, ref);
7834  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_return", file));
7835  if (into) {
7836  current_statement->handler3 = cb_build_move (rec, into);
7837  }
7838  current_statement->file = file;
7839 }
7840 
7841 /* ROLLBACK statement */
7842 
7843 void
7844 cb_emit_rollback (void)
7845 {
7846  cb_emit (CB_BUILD_FUNCALL_0 ("cob_rollback"));
7847 }
7848 
7849 /* SEARCH statement */
7850 
7851 static unsigned int
7852 search_set_keys (struct cb_field *f, cb_tree x)
7853 {
7854  struct cb_binary_op *p;
7855  struct cb_field *fldx;
7856  struct cb_field *fldy;
7857  int i;
7858 
7859  if (CB_REFERENCE_P (x)) {
7860  x = build_cond_88 (x);
7861  if (!x || x == cb_error_node) {
7862  return 1;
7863  }
7864  }
7865 
7866  p = CB_BINARY_OP (x);
7867  switch (p->op) {
7868  case '&':
7869  if (search_set_keys (f, p->x)) {
7870  return 1;
7871  }
7872  if (search_set_keys (f, p->y)) {
7873  return 1;
7874  }
7875  break;
7876  case '=':
7877  fldx = NULL;
7878  fldy = NULL;
7879  /* One of the operands must be a key reference */
7880  if (CB_REF_OR_FIELD_P (p->x)) {
7881  fldx = CB_FIELD_PTR (p->x);
7882  }
7883  if (CB_REF_OR_FIELD_P (p->y)) {
7884  fldy = CB_FIELD_PTR (p->y);
7885  }
7886  if (!fldx && !fldy) {
7887  cb_error_x (CB_TREE (current_statement),
7888  _("Invalid SEARCH ALL condition"));
7889  return 1;
7890  }
7891 
7892  for (i = 0; i < f->nkeys; ++i) {
7893  if (fldx == CB_FIELD_PTR (f->keys[i].key)) {
7894  f->keys[i].ref = p->x;
7895  f->keys[i].val = p->y;
7896  break;
7897  }
7898  }
7899  if (i == f->nkeys) {
7900  for (i = 0; i < f->nkeys; ++i) {
7901  if (fldy == CB_FIELD_PTR (f->keys[i].key)) {
7902  f->keys[i].ref = p->y;
7903  f->keys[i].val = p->x;
7904  break;
7905  }
7906  }
7907  if (i == f->nkeys) {
7908  cb_error_x (CB_TREE (current_statement),
7909  _("Invalid SEARCH ALL condition"));
7910  return 1;
7911  }
7912  }
7913  break;
7914  default:
7915  cb_error_x (CB_TREE (current_statement),
7916  _("Invalid SEARCH ALL condition"));
7917  return 1;
7918  }
7919  return 0;
7920 }
7921 
7922 static cb_tree
7923 cb_build_search_all (cb_tree table, cb_tree cond)
7924 {
7925  cb_tree c1;
7926  cb_tree c2;
7927  struct cb_field *f;
7928  int i;
7929 
7930  f = CB_FIELD_PTR (table);
7931  /* Set keys */
7932  for (i = 0; i < f->nkeys; i++) {
7933  f->keys[i].ref = NULL;
7934  }
7935  if (search_set_keys (f, cond)) {
7936  return NULL;
7937  }
7938  c1 = NULL;
7939 
7940  /* Build condition */
7941  for (i = 0; i < f->nkeys; i++) {
7942  if (f->keys[i].ref) {
7943  if (f->keys[i].dir == COB_ASCENDING) {
7944  c2 = cb_build_binary_op (f->keys[i].ref, '=',
7945  f->keys[i].val);
7946  } else {
7947  c2 = cb_build_binary_op (f->keys[i].val, '=',
7948  f->keys[i].ref);
7949  }
7950  if (c1 == NULL) {
7951  c1 = c2;
7952  } else {
7953  c1 = cb_build_binary_op (c1, '&', c2);
7954  }
7955  }
7956  }
7957 
7958  if (!c1) {
7959  return NULL;
7960  }
7961  return cb_build_cond (c1);
7962 }
7963 
7964 void
7965 cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
7966 {
7967  if (cb_validate_one (table)) {
7968  return;
7969  }
7970  if (cb_validate_one (varying)) {
7971  return;
7972  }
7973  if (table == cb_error_node) {
7974  return;
7975  }
7976  if (whens == cb_error_node) {
7977  return;
7978  }
7979  whens = cb_list_reverse (whens);
7980  cb_emit (cb_build_search (0, table, varying,
7981  cb_check_needs_break (at_end), whens));
7982 }
7983 
7984 void
7985 cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
7986 {
7987  cb_tree x;
7988  cb_tree stmt_lis;
7989 
7990  if (cb_validate_one (table)) {
7991  return;
7992  }
7993  if (table == cb_error_node) {
7994  return;
7995  }
7996  if (when == cb_error_node) {
7997  return;
7998  }
7999  x = cb_build_search_all (table, when);
8000  if (!x) {
8001  return;
8002  }
8003 
8004  stmt_lis = cb_check_needs_break (stmts);
8005  cb_emit (cb_build_search (1, table, NULL,
8006  cb_check_needs_break (at_end),
8007  cb_build_if (x, stmt_lis, NULL, 0)));
8008 }
8009 
8010 /* SET statement */
8011 
8012 void
8013 cb_emit_setenv (cb_tree x, cb_tree y)
8014 {
8015  cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_environment", x, y));
8016 }
8017 
8018 void
8019 cb_emit_set_to (cb_tree vars, cb_tree x)
8020 {
8021  cb_tree l;
8022  cb_tree v;
8023  struct cb_cast *p;
8024  enum cb_class class;
8025 
8026  if (cb_validate_one (x)) {
8027  return;
8028  }
8029  if (cb_validate_list (vars)) {
8030  return;
8031  }
8032 
8033 #if 0 /* RXWRXW - target check */
8034  /* Determine class of targets */
8035  for (l = vars; l; l = CB_CHAIN (l)) {
8036  if (CB_TREE_CLASS (CB_VALUE (l)) != CB_CLASS_UNKNOWN) {
8037  if (class == CB_CLASS_UNKNOWN) {
8038  class = CB_TREE_CLASS (CB_VALUE (l));
8039  } else if (class != CB_TREE_CLASS (CB_VALUE (l))) {
8040  break;
8041  }
8042  }
8043  }
8044  if (l || (class != CB_CLASS_INDEX && class != CB_CLASS_POINTER)) {
8045  cb_error_x (CB_TREE (current_statement),
8046  _("The targets of SET must be either indexes or pointers"));
8047  return;
8048  }
8049 #endif
8050 
8051  if (CB_CAST_P (x)) {
8052  p = CB_CAST (x);
8053  if (p->cast_type == CB_CAST_PROGRAM_POINTER) {
8054  for (l = vars; l; l = CB_CHAIN (l)) {
8055  v = CB_VALUE (l);
8056  if (!CB_REFERENCE_P (v)) {
8057  cb_error_x (CB_TREE (current_statement),
8058  _("SET targets must be PROGRAM-POINTER"));
8059  CB_VALUE (l) = cb_error_node;
8060  } else if (CB_FIELD(cb_ref(v))->usage != CB_USAGE_PROGRAM_POINTER) {
8061  cb_error_x (CB_TREE (current_statement),
8062  _("SET targets must be PROGRAM-POINTER"));
8063  CB_VALUE (l) = cb_error_node;
8064  }
8065  }
8066  }
8067  }
8068  /* Validate the targets */
8069  for (l = vars; l; l = CB_CHAIN (l)) {
8070  v = CB_VALUE (l);
8071  if (!CB_CAST_P (v)) {
8072  continue;
8073  }
8074  p = CB_CAST (v);
8075  if (p->cast_type == CB_CAST_ADDRESS &&
8076  !CB_FIELD (cb_ref (p->val))->flag_item_based &&
8077  CB_FIELD (cb_ref (p->val))->storage != CB_STORAGE_LINKAGE) {
8078  cb_error_x (p->val, _("The address of '%s' cannot be changed"),
8079  cb_name (p->val));
8080  CB_VALUE (l) = cb_error_node;
8081  }
8082  }
8083  if (cb_validate_list (vars)) {
8084  return;
8085  }
8086 
8087  for (l = vars; l; l = CB_CHAIN (l)) {
8088  class = cb_tree_class (CB_VALUE (l));
8089  switch (class) {
8090  case CB_CLASS_INDEX:
8091  case CB_CLASS_NUMERIC:
8092  case CB_CLASS_POINTER:
8093  cb_check_data_incompat (x);
8094  cb_emit (cb_build_move (x, CB_VALUE (l)));
8095  break;
8096  default:
8097  cb_error_x (CB_TREE (current_statement),
8098  _("SET target is invalid - '%s'"),
8099  cb_name (CB_VALUE(l)));
8100  break;
8101  }
8102  }
8103 }
8104 
8105 void
8106 cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
8107 {
8108  if (cb_validate_one (x)) {
8109  return;
8110  }
8111  if (cb_validate_list (l)) {
8112  return;
8113  }
8114  for (; l; l = CB_CHAIN (l)) {
8115  if (flag == cb_int0) {
8116  cb_emit (cb_build_add (CB_VALUE (l), x, cb_int0));
8117  } else {
8118  cb_emit (cb_build_sub (CB_VALUE (l), x, cb_int0));
8119  }
8120  }
8121 }
8122 
8123 void
8124 cb_emit_set_on_off (cb_tree l, cb_tree flag)
8125 {
8126  struct cb_system_name *s;
8127 
8128  if (cb_validate_list (l)) {
8129  return;
8130  }
8131  for (; l; l = CB_CHAIN (l)) {
8132  s = CB_SYSTEM_NAME (cb_ref (CB_VALUE (l)));
8133  cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_switch",
8134  cb_int (s->token), flag));
8135  }
8136 }
8137 
8138 void
8139 cb_emit_set_true (cb_tree l)
8140 {
8141  cb_tree x;
8142  struct cb_field *f;
8143  cb_tree ref;
8144  cb_tree val;
8145 
8146  for (; l; l = CB_CHAIN (l)) {
8147  x = CB_VALUE (l);
8148  if (x == cb_error_node) {
8149  return;
8150  }
8151  if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
8152  !CB_FIELD_P (x)) {
8153  cb_error_x (x, _("Invalid SET statement"));
8154  return;
8155  }
8156  f = CB_FIELD_PTR (x);
8157  if (f->level != 88) {
8158  cb_error_x (x, _("Invalid SET statement"));
8159  return;
8160  }
8161  ref = cb_build_field_reference (f->parent, x);
8162  val = CB_VALUE (f->values);
8163  if (CB_PAIR_P (val)) {
8164  val = CB_PAIR_X (val);
8165  }
8166  cb_emit (cb_build_move (val, ref));
8167  }
8168 }
8169 
8170 void
8171 cb_emit_set_false (cb_tree l)
8172 {
8173  cb_tree x;
8174  struct cb_field *f;
8175  cb_tree ref;
8176  cb_tree val;
8177 
8178  for (; l; l = CB_CHAIN (l)) {
8179  x = CB_VALUE (l);
8180  if (x == cb_error_node) {
8181  return;
8182  }
8183  if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
8184  !CB_FIELD_P (x)) {
8185  cb_error_x (x, _("Invalid SET statement"));
8186  return;
8187  }
8188  f = CB_FIELD_PTR (x);
8189  if (f->level != 88) {
8190  cb_error_x (x, _("Invalid SET statement"));
8191  return;
8192  }
8193  if (!f->false_88) {
8194  cb_error_x (x, _("Field does not have FALSE clause"));
8195  return;
8196  }
8197  ref = cb_build_field_reference (f->parent, x);
8198  val = CB_VALUE (f->false_88);
8199  if (CB_PAIR_P (val)) {
8200  val = CB_PAIR_X (val);
8201  }
8202  cb_emit (cb_build_move (val, ref));
8203  }
8204 }
8205 
8206 void
8207 cb_emit_set_attribute (cb_tree x, const int val_on, const int val_off)
8208 {
8209  struct cb_field *f;
8210 
8211  if (cb_validate_one (x)) {
8212  return;
8213  }
8214  if (!CB_REF_OR_FIELD_P (cb_ref (x))) {
8215  cb_error_x (CB_TREE (current_statement),
8216  _("SET ATTRIBUTE requires a screen item as subject"));
8217  return;
8218  }
8219  f = CB_FIELD_PTR (x);
8220  if (f->storage != CB_STORAGE_SCREEN) {
8221  cb_error_x (CB_TREE (current_statement),
8222  _("SET ATTRIBUTE subject does not refer to a screen item"));
8223  return;
8224  }
8225  cb_emit (cb_build_set_attribute (f, val_on, val_off));
8226 }
8227 
8228 void
8229 cb_emit_set_last_exception_to_off (void)
8230 {
8231  cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int0));
8232 }
8233 
8234 /* SORT statement */
8235 
8236 void
8237 cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col)
8238 {
8239  cb_tree l;
8240  struct cb_field *f;
8241 
8242  if (cb_validate_list (keys)) {
8243  return;
8244  }
8245  if (cb_ref (name) == cb_error_node) {
8246  return;
8247  }
8248  for (l = keys; l; l = CB_CHAIN (l)) {
8249  if (CB_VALUE (l) == NULL) {
8250  CB_VALUE (l) = name;
8251  }
8252  cb_ref (CB_VALUE (l));
8253  }
8254 
8255  if (CB_FILE_P (cb_ref (name))) {
8256  if (CB_FILE (cb_ref (name))->organization != COB_ORG_SORT) {
8257  cb_error_x (name, _("Invalid SORT filename"));
8258  }
8259  CB_FIELD_PTR (current_program->cb_sort_return)->count++;
8260  cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", cb_ref (name),
8261  cb_int (cb_list_length (keys)), col,
8262  CB_BUILD_CAST_ADDRESS (current_program->cb_sort_return),
8263  CB_FILE(cb_ref (name))->file_status));
8264  for (l = keys; l; l = CB_CHAIN (l)) {
8265  cb_emit (CB_BUILD_FUNCALL_4 ("cob_file_sort_init_key",
8266  cb_ref (name),
8267  CB_VALUE (l),
8268  CB_PURPOSE (l),
8269  cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset)));
8270  }
8271  } else {
8272  if (keys == NULL) {
8273  cb_error_x (name, _("Table sort without keys not implemented yet"));
8274  }
8275  cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort_init",
8276  cb_int (cb_list_length (keys)), col));
8277  for (l = keys; l; l = CB_CHAIN (l)) {
8278  cb_emit (CB_BUILD_FUNCALL_3 ("cob_table_sort_init_key",
8279  CB_VALUE (l),
8280  CB_PURPOSE (l),
8281  cb_int(CB_FIELD_PTR (CB_VALUE(l))->offset
8282  - CB_FIELD_PTR (CB_VALUE(l))->parent->offset)));
8283  }
8284  f = CB_FIELD (cb_ref (name));
8285  cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort", name,
8286  (f->depending
8287  ? cb_build_cast_int (f->depending)
8288  : cb_int (f->occurs_max))));
8289  }
8290 }
8291 
8292 void
8293 cb_emit_sort_using (cb_tree file, cb_tree l)
8294 {
8295  if (cb_validate_list (l)) {
8296  return;
8297  }
8298  for (; l; l = CB_CHAIN (l)) {
8299  if (CB_FILE (cb_ref(CB_VALUE(l)))->organization == COB_ORG_SORT) {
8300  cb_error_x (CB_TREE (current_statement),
8301  _("Invalid SORT USING parameter"));
8302  }
8303  cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_using",
8304  cb_ref (file), cb_ref (CB_VALUE (l))));
8305  }
8306 }
8307 
8308 void
8309 cb_emit_sort_input (cb_tree proc)
8310 {
8311  if (current_program->flag_debugging &&
8312  !current_statement->flag_in_debug) {
8313  cb_emit (cb_build_debug (cb_debug_contents, "SORT INPUT", NULL));
8314  }
8315  cb_emit (cb_build_perform_once (proc));
8316 }
8317 
8318 void
8319 cb_emit_sort_giving (cb_tree file, cb_tree l)
8320 {
8321  cb_tree p;
8322  int listlen;
8323 
8324  if (cb_validate_list (l)) {
8325  return;
8326  }
8327  for (p = l; p; p = CB_CHAIN (p)) {
8328  if (CB_FILE (cb_ref(CB_VALUE(p)))->organization == COB_ORG_SORT) {
8329  cb_error_x (CB_TREE (current_statement),
8330  _("Invalid SORT GIVING parameter"));
8331  }
8332  }
8333  listlen = cb_list_length (l);
8334  p = CB_BUILD_FUNCALL_2 ("cob_file_sort_giving", cb_ref (file), l);
8335  CB_FUNCALL(p)->varcnt = listlen;
8336  cb_emit (p);
8337 }
8338 
8339 void
8340 cb_emit_sort_output (cb_tree proc)
8341 {
8342  if (current_program->flag_debugging &&
8343  !current_statement->flag_in_debug) {
8344  if (current_statement->flag_merge) {
8345  cb_emit (cb_build_debug (cb_debug_contents,
8346  "MERGE OUTPUT", NULL));
8347  } else {
8348  cb_emit (cb_build_debug (cb_debug_contents,
8349  "SORT OUTPUT", NULL));
8350  }
8351  }
8352  cb_emit (cb_build_perform_once (proc));
8353 }
8354 
8355 void
8356 cb_emit_sort_finish (cb_tree file)
8357 {
8358  if (CB_FILE_P (cb_ref (file))) {
8359  cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_sort_close", cb_ref (file)));
8360  }
8361 }
8362 
8363 /* START statement */
8364 
8365 static unsigned int
8366 check_valid_key (const struct cb_file *cbf, const struct cb_field *f)
8367 {
8368  cb_tree kfld;
8369  struct cb_alt_key *cbak;
8370  struct cb_field *f1;
8371  struct cb_field *ff;
8372 
8373  if (cbf->organization != COB_ORG_INDEXED) {
8374  if (CB_FIELD_PTR (cbf->key) != f) {
8375  cb_error_x (CB_TREE (current_statement),
8376  _("Invalid key item"));
8377  return 1;
8378  }
8379  return 0;
8380  }
8381 
8382  ff = cb_field_founder (f);
8383  for (f1 = cbf->record; f1; f1 = f1->sister) {
8384  if (f1 == ff) {
8385  break;
8386  }
8387  }
8388  if (!f1) {
8389  cb_error_x (CB_TREE (current_statement), _("Invalid key item"));
8390  return 1;
8391  }
8392 
8393  kfld = cb_ref (cbf->key);
8394  if (kfld == cb_error_node) {
8395  return 1;
8396  }
8397  if (f->offset == CB_FIELD_PTR (kfld)->offset) {
8398  return 0;
8399  }
8400  for (cbak = cbf->alt_key_list; cbak; cbak = cbak->next) {
8401  kfld = cb_ref (cbak->key);
8402  if (kfld == cb_error_node) {
8403  return 1;
8404  }
8405  if (f->offset == CB_FIELD_PTR (kfld)->offset) {
8406  return 0;
8407  }
8408  }
8409  cb_error_x (CB_TREE (current_statement), _("Invalid key item"));
8410  return 1;
8411 }
8412 
8413 void
8414 cb_emit_start (cb_tree file, cb_tree op, cb_tree key, cb_tree keylen)
8415 {
8416  cb_tree kfld;
8417  cb_tree fl;
8418  cb_tree cbtkey;
8419  struct cb_file *f;
8420 
8421  if (cb_validate_one (key)) {
8422  return;
8423  }
8424  if (cb_validate_one (keylen)) {
8425  return;
8426  }
8427  if (file == cb_error_node) {
8428  return;
8429  }
8430  fl = cb_ref (file);
8431  if (fl == cb_error_node) {
8432  return;
8433  }
8434  f = CB_FILE (fl);
8435 
8436  if (f->organization != COB_ORG_INDEXED &&
8437  f->organization != COB_ORG_RELATIVE) {
8438  cb_error_x (CB_TREE (current_statement),
8439  _("%s not allowed on %s files"), "START", "SEQUENTIAL");
8440  return;
8441  }
8442  if (keylen && f->organization != COB_ORG_INDEXED) {
8443  cb_error_x (CB_TREE (current_statement),
8444  _("LENGTH/SIZE clause only allowed on INDEXED files"));
8445  return;
8446  }
8447  if (f->access_mode == COB_ACCESS_RANDOM) {
8448  cb_error_x (CB_TREE (current_statement),
8449  _("START not allowed with ACCESS MODE RANDOM"));
8450  return;
8451  }
8452 
8453  current_statement->file = fl;
8454  if (key) {
8455  kfld = cb_ref (key);
8456  if (kfld == cb_error_node) {
8457  return;
8458  }
8459  if (check_valid_key (f, CB_FIELD_PTR (kfld))) {
8460  return;
8461  }
8462  cbtkey = key;
8463  } else {
8464  cbtkey = f->key;
8465  }
8466 
8467  /* Check for file debugging */
8468  if (current_program->flag_debugging &&
8469  !current_statement->flag_in_debug &&
8470  f->flag_fl_debug) {
8471  /* Gen callback after start but before exception test */
8472  current_statement->flag_callback = 1;
8473  }
8474 
8475  cb_emit (CB_BUILD_FUNCALL_5 ("cob_start", fl, op, cbtkey, keylen,
8476  f->file_status));
8477 }
8478 
8479 /* STOP statement */
8480 
8481 void
8482 cb_emit_stop_run (cb_tree x)
8483 {
8484  cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x)));
8485 }
8486 
8487 /* STRING statement */
8488 
8489 void
8490 cb_emit_string (cb_tree items, cb_tree into, cb_tree pointer)
8491 {
8492  cb_tree start;
8493  cb_tree l;
8494  cb_tree end;
8495  cb_tree dlm;
8496 
8497  if (cb_validate_one (into)) {
8498  return;
8499  }
8500  if (cb_validate_one (pointer)) {
8501  return;
8502  }
8503  start = items;
8504  cb_emit (CB_BUILD_FUNCALL_2 ("cob_string_init", into, pointer));
8505  while (start) {
8506 
8507  /* Find DELIMITED item */
8508  for (end = start; end; end = CB_CHAIN (end)) {
8509  if (CB_PAIR_P (CB_VALUE (end))) {
8510  break;
8511  }
8512  }
8513 
8514  /* cob_string_delimited */
8515  dlm = end ? CB_PAIR_X (CB_VALUE (end)) : NULL;
8516  if (dlm == cb_int0) {
8517  dlm = NULL;
8518  }
8519  cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_delimited", dlm));
8520 
8521  /* cob_string_append */
8522  for (l = start; l != end; l = CB_CHAIN (l)) {
8523  cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_append",
8524  CB_VALUE (l)));
8525  }
8526 
8527  start = end ? CB_CHAIN (end) : NULL;
8528  }
8529  cb_emit (CB_BUILD_FUNCALL_0 ("cob_string_finish"));
8530 }
8531 
8532 /* UNLOCK statement */
8533 
8534 void
8535 cb_emit_unlock (cb_tree ref)
8536 {
8537  cb_tree file;
8538 
8539  if (ref != cb_error_node) {
8540  file = cb_ref (ref);
8541  if (file != cb_error_node) {
8542  cb_emit (CB_BUILD_FUNCALL_2 ("cob_unlock_file",
8543  file, CB_FILE(file)->file_status));
8544  current_statement->file = file;
8545  }
8546  }
8547 }
8548 
8549 /* UNSTRING statement */
8550 
8551 void
8552 cb_emit_unstring (cb_tree name, cb_tree delimited, cb_tree into,
8553  cb_tree pointer, cb_tree tallying)
8554 {
8555  if (cb_validate_one (name)) {
8556  return;
8557  }
8558  if (cb_validate_one (tallying)) {
8559  return;
8560  }
8561  if (cb_validate_list (delimited)) {
8562  return;
8563  }
8564  if (cb_validate_list (into)) {
8565  return;
8566  }
8567  cb_emit (CB_BUILD_FUNCALL_3 ("cob_unstring_init", name, pointer,
8568  cb_int (cb_list_length (delimited))));
8569  cb_emit_list (delimited);
8570  cb_emit_list (into);
8571  if (tallying) {
8572  cb_emit (CB_BUILD_FUNCALL_1 ("cob_unstring_tallying", tallying));
8573  }
8574  cb_emit (CB_BUILD_FUNCALL_0 ("cob_unstring_finish"));
8575 }
8576 
8577 cb_tree
8578 cb_build_unstring_delimited (cb_tree all, cb_tree value)
8579 {
8580  if (cb_validate_one (value)) {
8581  return cb_error_node;
8582  }
8583  return CB_BUILD_FUNCALL_2 ("cob_unstring_delimited", value, all);
8584 }
8585 
8586 cb_tree
8587 cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count)
8588 {
8589  if (cb_validate_one (name)) {
8590  return cb_error_node;
8591  }
8592  if (delimiter == NULL) {
8593  delimiter = cb_int0;
8594  }
8595  if (count == NULL) {
8596  count = cb_int0;
8597  }
8598  return CB_BUILD_FUNCALL_3 ("cob_unstring_into", name, delimiter, count);
8599 }
8600 
8601 /* WRITE statement */
8602 
8603 void
8604 cb_emit_write (cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
8605 {
8606  cb_tree file;
8607  cb_tree check_eop;
8608  struct cb_file *f;
8609 
8610  if (cb_validate_one (record)) {
8611  return;
8612  }
8613  if (cb_validate_one (from)) {
8614  return;
8615  }
8616  if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
8617  cb_error_x (CB_TREE (current_statement),
8618  _("%s requires a record name as subject"), "WRITE");
8619  return;
8620  }
8621  if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
8622  cb_error_x (CB_TREE (current_statement),
8623  _("%s subject does not refer to a record name"), "WRITE");
8624  return;
8625  }
8626  file = CB_TREE (CB_FIELD (cb_ref (record))->file);
8627  if (!file || file == cb_error_node) {
8628  return;
8629  }
8630  current_statement->file = file;
8631  f = CB_FILE (file);
8632 
8633  if (f->organization == COB_ORG_SORT) {
8634  cb_error_x (CB_TREE (current_statement),
8635  _("%s not allowed on %s files"), "WRITE", "SORT");
8636  } else if (current_statement->handler_id == COB_EC_I_O_INVALID_KEY &&
8637  (f->organization != COB_ORG_RELATIVE &&
8638  f->organization != COB_ORG_INDEXED)) {
8639  cb_error_x (CB_TREE(current_statement),
8640  _("INVALID KEY clause invalid with this file type"));
8641  } else if (lockopt) {
8642  if (f->lock_mode & COB_LOCK_AUTOMATIC) {
8643  cb_error_x (CB_TREE (current_statement),
8644  _("LOCK clause invalid with file LOCK AUTOMATIC"));
8645  } else if (opt != cb_int0) {
8646  cb_error_x (CB_TREE (current_statement),
8647  _("LOCK clause invalid here"));
8648  } else if (lockopt == cb_int1) {
8649  opt = cb_int (COB_WRITE_LOCK);
8650  }
8651  }
8652 
8653  if (from) {
8654  cb_emit (cb_build_move (from, record));
8655  }
8656 
8657  /* Check debugging on record name */
8658  if (current_program->flag_debugging &&
8659  !current_statement->flag_in_debug &&
8660  CB_FIELD_PTR (record)->flag_field_debug) {
8661  cb_emit (cb_build_debug (cb_debug_name,
8662  CB_FIELD_PTR (record)->name, NULL));
8663  cb_emit (cb_build_move (record, cb_debug_contents));
8664  cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
8665  }
8666  if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
8667  opt == cb_int0) {
8668  if (cb_flag_write_after || CB_FILE (file)->flag_line_adv) {
8669  opt = cb_int_hex (COB_WRITE_AFTER | COB_WRITE_LINES | 1);
8670  } else {
8671  opt = cb_int_hex (COB_WRITE_BEFORE | COB_WRITE_LINES | 1);
8672  }
8673  }
8674  if (current_statement->handler_id == COB_EC_I_O_EOP &&
8675  current_statement->handler1) {
8676  check_eop = cb_int1;
8677  } else {
8678  check_eop = cb_int0;
8679  }
8680  cb_emit (CB_BUILD_FUNCALL_5 ("cob_write", file, record, opt,
8681  f->file_status, check_eop));
8682 }
8683 
8684 cb_tree
8685 cb_build_write_advancing_lines (cb_tree pos, cb_tree lines)
8686 {
8687  cb_tree e;
8688  int opt;
8689 
8690  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8691  opt |= COB_WRITE_LINES;
8692  if (CB_LITERAL_P (lines)) {
8693  opt |= cb_get_int (lines);
8694  return cb_int_hex (opt);
8695  }
8696  e = cb_build_binary_op (cb_int (opt), '+', lines);
8697  return cb_build_cast_int (e);
8698 }
8699 
8700 cb_tree
8701 cb_build_write_advancing_mnemonic (cb_tree pos, cb_tree mnemonic)
8702 {
8703  int opt;
8704  int token;
8705 
8706  if (mnemonic == cb_error_node) {
8707  return cb_int0;
8708  }
8709  if (cb_ref (mnemonic) == cb_error_node) {
8710  return cb_int0;
8711  }
8712  token = CB_SYSTEM_NAME (cb_ref (mnemonic))->token;
8713  switch (token) {
8714  case CB_FEATURE_FORMFEED:
8715  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8716  return cb_int_hex (opt | COB_WRITE_PAGE);
8717  case CB_FEATURE_C01:
8718  case CB_FEATURE_C02:
8719  case CB_FEATURE_C03:
8720  case CB_FEATURE_C04:
8721  case CB_FEATURE_C05:
8722  case CB_FEATURE_C06:
8723  case CB_FEATURE_C07:
8724  case CB_FEATURE_C08:
8725  case CB_FEATURE_C09:
8726  case CB_FEATURE_C10:
8727  case CB_FEATURE_C11:
8728  case CB_FEATURE_C12:
8729  opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8730  return cb_int_hex (opt | COB_WRITE_CHANNEL | COB_WRITE_PAGE | token);
8731  default:
8732  cb_error_x (mnemonic, _("Invalid mnemonic name"));
8733  return cb_int0;
8734  }
8735 }
8736 
8737 cb_tree
8738 cb_build_write_advancing_page (cb_tree pos)
8739 {
8740  int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
8741 
8742  return cb_int_hex (opt | COB_WRITE_PAGE);
8743 }
8744 
8745 #ifndef HAVE_DESIGNATED_INITS
8746 void
8747 cobc_init_typeck (void)
8748 {
8749  const unsigned char *p;
8750 
8751  memset (valid_char, 0, sizeof(valid_char));
8752  for (p = pvalid_char; *p; ++p) {
8753  valid_char[*p] = 1;
8754  }
8755  memset(expr_prio, 0, sizeof(expr_prio));
8756  expr_prio['x' & 0xFF] = 0;
8757  expr_prio['^' & 0xFF] = 1;
8758  expr_prio['*' & 0xFF] = 2;
8759  expr_prio['/' & 0xFF] = 2;
8760  expr_prio['+' & 0xFF] = 3;
8761  expr_prio['-' & 0xFF] = 3;
8762  expr_prio['=' & 0xFF] = 4;
8763  expr_prio['~' & 0xFF] = 4;
8764  expr_prio['<' & 0xFF] = 4;
8765  expr_prio['>' & 0xFF] = 4;
8766  expr_prio['[' & 0xFF] = 4;
8767  expr_prio[']' & 0xFF] = 4;
8768  expr_prio['!' & 0xFF] = 5;
8769  expr_prio['&' & 0xFF] = 6;
8770  expr_prio['|' & 0xFF] = 7;
8771  expr_prio[')' & 0xFF] = 8;
8772  expr_prio['(' & 0xFF] = 9;
8773  expr_prio[0] = 10;
8774 }
8775 #endif
cb_field::flag_justified
unsigned int flag_justified
Definition: tree.h:706
cb_field::indexes
int indexes
Definition: tree.h:678
build_literal
struct cb_literal * build_literal(const enum cb_category category, const void *data, const size_t size)
Definition: tree.c:722
cb_reference::check
cb_tree check
Definition: tree.h:880
cb_field::name
const char * name
Definition: tree.h:645
CB_NUMERIC_LITERAL_P
#define CB_NUMERIC_LITERAL_P(x)
Definition: tree.h:603
CB_FEATURE_C01
#define CB_FEATURE_C01
Definition: tree.h:198
COB_WRITE_LINES
#define COB_WRITE_LINES
Definition: common.h:802
cb_build_debug_item
void cb_build_debug_item(void)
Definition: typeck.c:2243
cb_field::flag_is_pointer
unsigned int flag_is_pointer
Definition: tree.h:710
CB_BUILD_PARENTHESIS
#define CB_BUILD_PARENTHESIS(x)
Definition: tree.h:1846
CB_PAIR_X
#define CB_PAIR_X(x)
Definition: tree.h:1205
validate_attrs
static int validate_attrs(cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, cb_tree size_is)
Definition: typeck.c:5142
cb_field::occurs_max
int occurs_max
Definition: tree.h:677
cb_check_group_name
static cb_tree cb_check_group_name(cb_tree x)
Definition: typeck.c:592
cb_debug_sub_2
cb_tree cb_debug_sub_2
Definition: typeck.c:86
cb_field::flag_real_binary
unsigned int flag_real_binary
Definition: tree.h:708
d2
static cob_decimal d2
Definition: intrinsic.c:80
cb_report::line_counter
cb_tree line_counter
Definition: tree.h:1215
CB_TREE
#define CB_TREE(x)
Definition: tree.h:440
cb_build_move_field
static cb_tree cb_build_move_field(cb_tree src, cb_tree dst)
Definition: typeck.c:7271
cb_build_any_intrinsic
cb_tree cb_build_any_intrinsic(cb_tree args)
Definition: tree.c:3295
optim_table::optim_name
const char *const optim_name
Definition: typeck.c:52
CB_REFERENCE_P
#define CB_REFERENCE_P(x)
Definition: tree.h:902
cb_field_size
static int cb_field_size(const cb_tree x)
Definition: typeck.c:790
cb_error_x
void cb_error_x(cb_tree x, const char *fmt,...)
Definition: error.c:233
cb_true
cb_tree cb_true
Definition: tree.c:122
CB_LABEL
#define CB_LABEL(x)
Definition: tree.h:801
cobc_main_malloc
void * cobc_main_malloc(const size_t size)
Definition: cobc.c:702
CB_SYSTEM_NAME
#define CB_SYSTEM_NAME(x)
Definition: tree.h:586
cb_list_append
cb_tree cb_list_append(cb_tree l1, cb_tree l2)
Definition: tree.c:1305
cb_check_numeric_edited_name
static cb_tree cb_check_numeric_edited_name(cb_tree x)
Definition: typeck.c:633
cb_build_optim_sub
static cb_tree cb_build_optim_sub(cb_tree v, cb_tree n)
Definition: typeck.c:3951
cb_expr_shift
static void cb_expr_shift(int token, cb_tree value)
Definition: typeck.c:2970
CB_TREE_CATEGORY
#define CB_TREE_CATEGORY(x)
Definition: tree.h:443
cb_int1
cb_tree cb_int1
Definition: tree.c:134
CB_STATEMENT_P
#define CB_STATEMENT_P(x)
Definition: tree.h:1156
CB_PAIR_P
#define CB_PAIR_P(x)
Definition: tree.h:1204
cb_build_tallying_data
cb_tree cb_build_tallying_data(cb_tree x)
Definition: typeck.c:5856
cb_literal::sign
short sign
Definition: tree.h:597
cobc_abort_pr
void cobc_abort_pr(const char *fmt,...)
Definition: cobc.c:587
cb_picture::size
int size
Definition: tree.h:622
cb_label::name
const char * name
Definition: tree.h:766
bin_sub_funcs
static const struct optim_table bin_sub_funcs[]
Definition: typeck.c:378
cb_needs_01
size_t cb_needs_01
Definition: field.c:37
COB_SCREEN_TYPE_VALUE
#define COB_SCREEN_TYPE_VALUE
Definition: common.h:929
CB_INTEGER
#define CB_INTEGER(x)
Definition: tree.h:522
cb_check_index_p
size_t cb_check_index_p(cb_tree x)
Definition: typeck.c:887
COB_SCREEN_BELL
#define COB_SCREEN_BELL
Definition: common.h:900
cb_statement::debug_check
cb_tree debug_check
Definition: tree.h:1145
cb_debug_name
cb_tree cb_debug_name
Definition: typeck.c:84
system_tab
static const struct system_table system_tab[]
Definition: typeck.c:282
cob_u32_t
#define cob_u32_t
Definition: common.h:31
cb_build_replacing_trailing
cb_tree cb_build_replacing_trailing(cb_tree x, cb_tree y, cb_tree l)
Definition: typeck.c:5947
CB_CALL_BY_REFERENCE
#define CB_CALL_BY_REFERENCE
Definition: tree.h:44
cb_emit_accept_day_yyyyddd
void cb_emit_accept_day_yyyyddd(cb_tree var)
Definition: typeck.c:4539
cb_build_comment
cb_tree cb_build_comment(const char *str)
Definition: tree.c:1540
CB_FEATURE_C07
#define CB_FEATURE_C07
Definition: tree.h:204
CB_CONST_P
#define CB_CONST_P(x)
Definition: tree.h:477
CB_FEATURE_C10
#define CB_FEATURE_C10
Definition: tree.h:207
cb_build_cancel
cb_tree cb_build_cancel(const cb_tree target)
Definition: tree.c:3088
cb_source_file
const char * cb_source_file
Definition: cobc.c:145
CB_FEATURE_C09
#define CB_FEATURE_C09
Definition: tree.h:206
CB_CAST_P
#define CB_CAST_P(x)
Definition: tree.h:963
cb_field::flag_is_pdiv_opt
unsigned int flag_is_pdiv_opt
Definition: tree.h:725
cb_build_filler
cb_tree cb_build_filler(void)
Definition: tree.c:2591
cb_picture::scale
int scale
Definition: tree.h:626
cb_file::flag_line_adv
unsigned int flag_line_adv
Definition: tree.h:855
cb_intr_whencomp
cb_tree cb_intr_whencomp
Definition: tree.c:142
cb_file::name
const char * name
Definition: tree.h:820
cb_key::val
cb_tree val
Definition: tree.h:639
cb_field::odo_level
unsigned int odo_level
Definition: tree.h:687
CB_VALID_TREE
#define CB_VALID_TREE(x)
Definition: tree.h:445
check
if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack check
Definition: flag.def:99
cb_program::report_list
cb_tree report_list
Definition: tree.h:1262
cb_build_constant
cb_tree cb_build_constant(cb_tree name, cb_tree value)
Definition: tree.c:2189
cb_emit_exit
void cb_emit_exit(const unsigned int goback)
Definition: typeck.c:5653
COB_SCREEN_TYPE_FIELD
#define COB_SCREEN_TYPE_FIELD
Definition: common.h:928
cb_field::flag_any_length
unsigned int flag_any_length
Definition: tree.h:712
cobc_parse_malloc
void * cobc_parse_malloc(const size_t size)
Definition: cobc.c:809
cob_put_sign_ebcdic
static void cob_put_sign_ebcdic(unsigned char *p, const int sign)
Definition: typeck.c:6959
CB_FIELD_ADD
#define CB_FIELD_ADD(x, y)
Definition: tree.h:1856
COB_READ_NO_LOCK
#define COB_READ_NO_LOCK
Definition: common.h:818
cb_warning_x
void cb_warning_x(cb_tree x, const char *fmt,...)
Definition: error.c:222
cb_field::debug_section
struct cb_label * debug_section
Definition: tree.h:661
cb_norm_high
cb_tree cb_norm_high
Definition: tree.c:131
cb_build_call
cb_tree cb_build_call(const cb_tree name, const cb_tree args, const cb_tree stmt1, const cb_tree stmt2, const cb_tree returning, const cob_u32_t is_system_call, const int convention)
Definition: tree.c:3067
move_warning
static void move_warning(cb_tree src, cb_tree dst, const unsigned int value_flag, const int flag, const int src_flag, const char *msg)
Definition: typeck.c:6025
cb_field::sister
struct cb_field * sister
Definition: tree.h:653
cb_validate_program_environment
void cb_validate_program_environment(struct cb_program *prog)
Definition: typeck.c:1891
expr_expand
static void expr_expand(cb_tree *x)
Definition: typeck.c:3088
cb_check_lit_subs
static void cb_check_lit_subs(struct cb_reference *r, const int numsubs, const int numindex)
Definition: typeck.c:746
CB_DEVICE_SYSOUT
#define CB_DEVICE_SYSOUT
Definition: tree.h:154
bin_add_funcs
static const struct optim_table bin_add_funcs[]
Definition: typeck.c:343
count_pic_alphanumeric_edited
static int count_pic_alphanumeric_edited(struct cb_field *field)
Definition: typeck.c:6060
cb_statement::flag_no_based
unsigned int flag_no_based
Definition: tree.h:1149
cb_build_move_zero
static cb_tree cb_build_move_zero(cb_tree x)
Definition: typeck.c:6843
value_is_numeric_field
static COB_INLINE COB_A_INLINE int value_is_numeric_field(cb_tree pos)
Definition: typeck.c:4260
cb_field::children
struct cb_field * children
Definition: tree.h:652
COB_LOCK_AUTOMATIC
#define COB_LOCK_AUTOMATIC
Definition: common.h:775
cb_system_name
Definition: tree.h:579
CB_LITERAL
#define CB_LITERAL(x)
Definition: tree.h:601
CB_ERROR
Definition: cobc.h:141
cob_refer_ebcdic
static const unsigned char cob_refer_ebcdic[256]
Definition: typeck.c:242
CB_PREFIX_LABEL
#define CB_PREFIX_LABEL
Definition: tree.h:37
cb_build_write_advancing_lines
cb_tree cb_build_write_advancing_lines(cb_tree pos, cb_tree lines)
Definition: typeck.c:8685
is_reference_with_value
static COB_INLINE COB_A_INLINE int is_reference_with_value(cb_tree pos)
Definition: typeck.c:4252
emit_field_display
static void emit_field_display(const cb_tree x, const cb_tree pos, const cb_tree fgc, const cb_tree bgc, const cb_tree scroll, const cb_tree size_is, const int dispattrs)
Definition: typeck.c:5202
cb_file::lock_mode
int lock_mode
Definition: tree.h:846
cb_picture::str
char * str
Definition: tree.h:621
CB_INTRINSIC
#define CB_INTRINSIC(x)
Definition: tree.h:1001
CB_DEVICE_SYSERR
#define CB_DEVICE_SYSERR
Definition: tree.h:155
cb_build_move
cb_tree cb_build_move(cb_tree src, cb_tree dst)
Definition: typeck.c:7333
cb_emit_sort_output
void cb_emit_sort_output(cb_tree proc)
Definition: typeck.c:8340
cb_build_implicit_field
cb_tree cb_build_implicit_field(cb_tree name, const int len)
Definition: tree.c:2175
cb_build_perform_once
cb_tree cb_build_perform_once(cb_tree body)
Definition: typeck.c:7523
cb_field::occurs_min
int occurs_min
Definition: tree.h:676
CB_FIELD_PTR
#define CB_FIELD_PTR(x)
Definition: tree.h:745
cb_emit_unstring
void cb_emit_unstring(cb_tree name, cb_tree delimited, cb_tree into, cb_tree pointer, cb_tree tallying)
Definition: typeck.c:8552
cb_debug_line
cb_tree cb_debug_line
Definition: typeck.c:83
output_screen_to
static void output_screen_to(struct cb_field *p, const unsigned int sisters)
Definition: typeck.c:4222
cb_tree_common
Definition: tree.h:428
cb_literal
Definition: tree.h:591
decimal_stack
static cb_tree decimal_stack
Definition: typeck.c:94
emit_move_corresponding
static unsigned int emit_move_corresponding(cb_tree x1, cb_tree x2)
Definition: typeck.c:4145
CB_CONV_STDCALL
#define CB_CONV_STDCALL
Definition: tree.h:135
cb_emit_ready_trace
void cb_emit_ready_trace(void)
Definition: typeck.c:7690
cb_field::flag_odo_relative
unsigned int flag_odo_relative
Definition: tree.h:731
cb_emit_search_all
void cb_emit_search_all(cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
Definition: typeck.c:7985
CB_SIZE_8
#define CB_SIZE_8
Definition: tree.h:52
cb_get_int
int cb_get_int(const cb_tree x)
Definition: tree.c:1101
cb_reference::value
cb_tree value
Definition: tree.h:876
cb_program::reference_list
cb_tree reference_list
Definition: tree.h:1255
is_less_than_four_or_is_six
static COB_INLINE COB_A_INLINE int is_less_than_four_or_is_six(int x)
Definition: typeck.c:4246
cb_program
Definition: tree.h:1238
cb_reference
Definition: tree.h:873
cb_field::screen_from
cb_tree screen_from
Definition: tree.h:665
cb_validate_one
static size_t cb_validate_one(cb_tree x)
Definition: typeck.c:545
cb_norm_low
cb_tree cb_norm_low
Definition: tree.c:130
warningopt
int warningopt
Definition: cobc.c:176
CB_ASSIGN_IBM
#define CB_ASSIGN_IBM
Definition: cobc.h:78
check_valid_key
static unsigned int check_valid_key(const struct cb_file *cbf, const struct cb_field *f)
Definition: typeck.c:8366
cb_verify
unsigned int cb_verify(const enum cb_support, const char *)
Definition: error.c:246
cb_id
int cb_id
Definition: cobc.c:163
CB_FEATURE_FORMFEED
#define CB_FEATURE_FORMFEED
Definition: tree.h:196
cb_build_perform_times
cb_tree cb_build_perform_times(cb_tree times)
Definition: typeck.c:7536
cb_build_field_reference
cb_tree cb_build_field_reference(struct cb_field *f, cb_tree ref)
Definition: tree.c:2604
cb_emit_accept
void cb_emit_accept(cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr)
Definition: typeck.c:4341
cb_emit_accept_user_name
void cb_emit_accept_user_name(cb_tree var)
Definition: typeck.c:4503
CB_CAST
#define CB_CAST(x)
Definition: tree.h:962
validate_inspect
static void validate_inspect(cb_tree x, cb_tree y, const unsigned int replconv)
Definition: typeck.c:5714
CB_PURPOSE_INT
#define CB_PURPOSE_INT(x)
Definition: tree.h:1197
cb_emit_set_up_down
void cb_emit_set_up_down(cb_tree l, cb_tree flag, cb_tree x)
Definition: typeck.c:8106
cb_chk_alpha_cond
static int cb_chk_alpha_cond(cb_tree x)
Definition: typeck.c:3712
cb_emit_display
void cb_emit_display(cb_tree values, cb_tree upon, cb_tree no_adv, cb_tree pos, struct cb_attr_struct *attr_ptr)
Definition: typeck.c:5236
CB_BUILD_FUNCALL_4
#define CB_BUILD_FUNCALL_4(f, a1, a2, a3, a4)
Definition: tree.h:1811
cb_ref
cb_tree cb_ref(cb_tree x)
Definition: tree.c:2653
cb_build_field_tree
cb_tree cb_build_field_tree(cb_tree level, cb_tree name, struct cb_field *last_field, enum cb_storage storage, struct cb_file *fn, const int expl_level)
Definition: field.c:90
cb_tree_common::source_file
const char * source_file
Definition: tree.h:431
cb_name
char * cb_name(cb_tree x)
Definition: tree.c:735
cb_key::ref
cb_tree ref
Definition: tree.h:638
CB_SIZE_2
#define CB_SIZE_2
Definition: tree.h:50
CB_PAIR_Y
#define CB_PAIR_Y(x)
Definition: tree.h:1206
cb_emit_evaluate
void cb_emit_evaluate(cb_tree subject_list, cb_tree case_list)
Definition: typeck.c:5571
CB_ALPHABET_ASCII
#define CB_ALPHABET_ASCII
Definition: tree.h:108
cb_emit_accept_escape_key
void cb_emit_accept_escape_key(cb_tree var)
Definition: typeck.c:4485
cb_program::nested_level
int nested_level
Definition: tree.h:1295
cb_build_field
cb_tree cb_build_field(cb_tree name)
Definition: tree.c:2159
cb_field::pic
struct cb_picture * pic
Definition: tree.h:659
cb_picture::digits
cob_u32_t digits
Definition: tree.h:625
f2
cob_field f2
Definition: cobxref.c.l.h:55
CB_BUILD_FUNCALL_1
#define CB_BUILD_FUNCALL_1(f, a1)
Definition: tree.h:1799
cb_build_add
cb_tree cb_build_add(cb_tree v, cb_tree n, cb_tree round_opt)
Definition: typeck.c:4015
cb_build_symbolic_chars
void cb_build_symbolic_chars(const cb_tree sym_list, const cb_tree alphabet)
Definition: tree.c:2289
cb_build_mul
static cb_tree cb_build_mul(cb_tree v, cb_tree n, cb_tree round_opt)
Definition: typeck.c:3368
cb_emit_set_last_exception_to_off
void cb_emit_set_last_exception_to_off(void)
Definition: typeck.c:8229
cb_build_perform_forever
cb_tree cb_build_perform_forever(cb_tree body)
Definition: typeck.c:7561
cb_alphabet_name
Definition: tree.h:538
COB_SMALL_BUFF
#define COB_SMALL_BUFF
Definition: common.h:540
cb_program::max_call_param
int max_call_param
Definition: tree.h:1298
cb_attr_struct::scroll
cb_tree scroll
Definition: tree.h:1126
cb_build_index
cb_tree cb_build_index(cb_tree x, cb_tree values, const unsigned int indexed_by, struct cb_field *qual)
Definition: typeck.c:1337
cb_zero
cb_tree cb_zero
Definition: tree.c:125
CB_PICTURE
#define CB_PICTURE(x)
Definition: tree.h:631
CB_LABEL_P
#define CB_LABEL_P(x)
Definition: tree.h:802
cb_emit_goto
void cb_emit_goto(cb_tree target, cb_tree depending)
Definition: typeck.c:5629
cb_program::crt_status
cb_tree crt_status
Definition: tree.h:1287
CB_ALPHABET_NATIVE
#define CB_ALPHABET_NATIVE
Definition: tree.h:107
COB_INLINE
#define COB_INLINE
Definition: common.h:354
COB_ORG_INDEXED
#define COB_ORG_INDEXED
Definition: common.h:745
CB_BUILD_CAST_PPOINTER
#define CB_BUILD_CAST_PPOINTER(x)
Definition: tree.h:1844
COB_MINI_BUFF
#define COB_MINI_BUFF
Definition: common.h:539
CB_PURPOSE
#define CB_PURPOSE(x)
Definition: tree.h:1192
cb_alt_key::next
struct cb_alt_key * next
Definition: tree.h:812
overlapping
static size_t overlapping
Definition: typeck.c:103
cb_emit_commit
void cb_emit_commit(void)
Definition: typeck.c:5023
cb_build_move_num_zero
static cb_tree cb_build_move_num_zero(cb_tree x)
Definition: typeck.c:6766
cb_class_name
Definition: tree.h:555
cb_attr_struct::size_is
cb_tree size_is
Definition: tree.h:1129
cb_build_search
cb_tree cb_build_search(const int flag_all, const cb_tree table, const cb_tree var, const cb_tree end_stmt, const cb_tree whens)
Definition: tree.c:3049
d1
cob_decimal * d1
Definition: cobxref.c.l.h:21
cb_emit_delete
void cb_emit_delete(cb_tree file)
Definition: typeck.c:5039
cb_statement::handler_id
int handler_id
Definition: tree.h:1148
optim_table::optim_val
enum cb_optim optim_val
Definition: typeck.c:53
decimal_expand
static void decimal_expand(cb_tree d, cb_tree x)
Definition: typeck.c:3285
COB_MAX_DEC_STRUCT
#define COB_MAX_DEC_STRUCT
Definition: common.h:571
cb_emit_string
void cb_emit_string(cb_tree items, cb_tree into, cb_tree pointer)
Definition: typeck.c:8490
cb_report::cname
char * cname
Definition: tree.h:1213
cb_emit_accept_date_yyyymmdd
void cb_emit_accept_date_yyyymmdd(cb_tree var)
Definition: typeck.c:4521
cb_false
cb_tree cb_false
Definition: tree.c:123
cb_program::file_list
cb_tree file_list
Definition: tree.h:1252
cb_category
cb_category
Definition: tree.h:226
cb_build_perform_exit
cb_tree cb_build_perform_exit(struct cb_label *label)
Definition: typeck.c:7574
cb_build_sub
cb_tree cb_build_sub(cb_tree v, cb_tree n, cb_tree round_opt)
Definition: typeck.c:4058
dpush
#define dpush(x)
Definition: typeck.c:73
cb_field_variable_size
struct cb_field * cb_field_variable_size(const struct cb_field *f)
Definition: tree.c:2239
cobc_check_string
void * cobc_check_string(const char *dupstr)
Definition: cobc.c:951
expr_stack_size
static int expr_stack_size
Definition: typeck.c:106
cb_emit_accept_exception_status
void cb_emit_accept_exception_status(cb_tree var)
Definition: typeck.c:4494
cb_any
cb_tree cb_any
Definition: tree.c:121
cb_field::special_index
cob_u32_t special_index
Definition: tree.h:690
cb_program::decimal_index
int decimal_index
Definition: tree.h:1293
cb_build_replacing_all
cb_tree cb_build_replacing_all(cb_tree x, cb_tree y, cb_tree l)
Definition: typeck.c:5926
cb_field::level
int level
Definition: tree.h:673
cb_field::flag_is_global
unsigned char flag_is_global
Definition: tree.h:699
cb_build_tallying_value
cb_tree cb_build_tallying_value(cb_tree x, cb_tree l)
Definition: typeck.c:5907
cb_build_decimal
cb_tree cb_build_decimal(const int id)
Definition: tree.c:1770
cb_fits_long_long
int cb_fits_long_long(const cb_tree x)
Definition: tree.c:991
COB_READ_PREVIOUS
#define COB_READ_PREVIOUS
Definition: common.h:814
cb_quote
cb_tree cb_quote
Definition: tree.c:132
cb_build_numsize_literal
cb_tree cb_build_numsize_literal(const void *data, const size_t size, const int sign)
Definition: tree.c:1699
cb_build_if_check_break
cb_tree cb_build_if_check_break(cb_tree cond, cb_tree stmts)
Definition: typeck.c:5671
cobc_parse_strdup
void * cobc_parse_strdup(const char *dupstr)
Definition: cobc.c:827
CB_WORD_ITEMS
#define CB_WORD_ITEMS(x)
Definition: tree.h:906
cb_file::flag_ext_assign
unsigned int flag_ext_assign
Definition: tree.h:851
cb_space
cb_tree cb_space
Definition: tree.c:127
cb_emit_release
void cb_emit_release(cb_tree record, cb_tree from)
Definition: typeck.c:7780
cb_picture::orig
char * orig
Definition: tree.h:620
CB_FILE
#define CB_FILE(x)
Definition: tree.h:858
cb_emit_read
void cb_emit_read(cb_tree ref, cb_tree next, cb_tree into, cb_tree key, cb_tree lock_opts)
Definition: typeck.c:7586
cb_program::flag_screen
unsigned int flag_screen
Definition: tree.h:1309
CB_SIZES_INT
#define CB_SIZES_INT(x)
Definition: tree.h:1199
expr_lh
static cb_tree expr_lh
Definition: typeck.c:100
COB_WRITE_AFTER
#define COB_WRITE_AFTER
Definition: common.h:805
CB_FUNCALL
#define CB_FUNCALL(x)
Definition: tree.h:951
pvalid_char
static const unsigned char pvalid_char[]
Definition: typeck.c:201
cb_build_string
cb_tree cb_build_string(const void *data, const size_t size)
Definition: tree.c:1526
file
if fold fold static computed alternate extra correct stack on syntax debugging source implicit stack syntax write single recursive relax optional file
Definition: flag.def:129
cb_program::flag_debugging
unsigned int flag_debugging
Definition: tree.h:1320
cob_s64_t
#define cob_s64_t
Definition: common.h:51
cb_file::debug_section
struct cb_label * debug_section
Definition: tree.h:839
cb_emit_corresponding
void cb_emit_corresponding(cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
Definition: typeck.c:4124
get_value
static int get_value(cb_tree x)
Definition: typeck.c:1843
cb_attr_struct::bgc
cb_tree bgc
Definition: tree.h:1125
cb_build_program_id
char * cb_build_program_id(cb_tree name, cb_tree alt_name, const cob_u32_t is_func)
Definition: typeck.c:1190
cb_build_set_attribute
cb_tree cb_build_set_attribute(const struct cb_field *fld, const int val_on, const int val_off)
Definition: tree.c:3226
CB_SIZE_4
#define CB_SIZE_4
Definition: tree.h:51
COB_S64_C
#define COB_S64_C(x)
Definition: common.h:54
expr_op
static int expr_op
Definition: typeck.c:99
CB_LITERAL_P
#define CB_LITERAL_P(x)
Definition: tree.h:602
cb_build_tallying_leading
cb_tree cb_build_tallying_leading(void)
Definition: typeck.c:5885
cb_emit_list
#define cb_emit_list(l)
Definition: typeck.c:77
get_line_and_column_from_pos
static void get_line_and_column_from_pos(const cb_tree pos, cb_tree *const line, cb_tree *const column)
Definition: typeck.c:5173
expr_node::token
int token
Definition: typeck.c:64
expr_node::value
cb_tree value
Definition: typeck.c:66
cb_build_picture
cb_tree cb_build_picture(const char *str)
Definition: tree.c:1800
cb_literal::all
short all
Definition: tree.h:598
cb_emit_accept_date
void cb_emit_accept_date(cb_tree var)
Definition: typeck.c:4512
cobc_main_realloc
void * cobc_main_realloc(void *prevptr, const size_t size)
Definition: cobc.c:738
CB_BUILD_NEGATION
#define CB_BUILD_NEGATION(x)
Definition: tree.h:1847
cb_statement::name
const char * name
Definition: tree.h:1137
cb_emit_unlock
void cb_emit_unlock(cb_tree ref)
Definition: typeck.c:8535
cb_program::debug_list
cb_tree debug_list
Definition: tree.h:1264
cb_build_section_name
cb_tree cb_build_section_name(cb_tree name, const int sect_or_para)
Definition: typeck.c:1251
cb_emit_free
void cb_emit_free(cb_tree vars)
Definition: typeck.c:5588
cb_emit_env_value
void cb_emit_env_value(cb_tree value)
Definition: typeck.c:5115
TOKEN
#define TOKEN(offset)
Definition: typeck.c:70
cob_u8_t
#define cob_u8_t
Definition: common.h:27
CB_VALUE
#define CB_VALUE(x)
Definition: tree.h:1193
cb_word::name
const char * name
Definition: tree.h:865
cb_emit_move_corresponding
void cb_emit_move_corresponding(cb_tree x1, cb_tree x2)
Definition: typeck.c:4175
cb_emit_accept_environment
void cb_emit_accept_environment(cb_tree var)
Definition: typeck.c:4587
cb_program::alter_gotos
struct cb_alter_id * alter_gotos
Definition: tree.h:1275
CB_TREE_CLASS
#define CB_TREE_CLASS(x)
Definition: tree.h:442
cb_alphabet_name::alphachr
int alphachr[256]
Definition: tree.h:547
cb_program::alter_list
cb_tree alter_list
Definition: tree.h:1263
cb_debug_item
cb_tree cb_debug_item
Definition: typeck.c:82
COB_MAX_WORDLEN
#define COB_MAX_WORDLEN
Definition: common.h:574
cb_check_overlapping
static size_t cb_check_overlapping(cb_tree src, cb_tree dst, struct cb_field *src_f, struct cb_field *dst_f)
Definition: typeck.c:6078
COB_ACCESS_DYNAMIC
#define COB_ACCESS_DYNAMIC
Definition: common.h:752
valid_char
static unsigned char valid_char[256]
Definition: typeck.c:200
cb_attr_struct
Definition: tree.h:1123
CB_SIZE_AUTO
#define CB_SIZE_AUTO
Definition: tree.h:48
COB_SCREEN_ERASE_EOL
#define COB_SCREEN_ERASE_EOL
Definition: common.h:904
CB_BUILD_FUNCALL_3
#define CB_BUILD_FUNCALL_3(f, a1, a2, a3)
Definition: tree.h:1807
cb_build_optim_add
static cb_tree cb_build_optim_add(cb_tree v, cb_tree n)
Definition: typeck.c:3876
cb_emit_allocate
void cb_emit_allocate(cb_tree target1, cb_tree target2, cb_tree size, cb_tree initialize)
Definition: typeck.c:4668
cb_build_alphanumeric_literal
cb_tree cb_build_alphanumeric_literal(const void *data, const size_t size)
Definition: tree.c:1716
cb_build_display_mnemonic
cb_tree cb_build_display_mnemonic(cb_tree x)
Definition: typeck.c:5340
CB_PERFORM
#define CB_PERFORM(x)
Definition: tree.h:1118
COB_READ_WAIT_LOCK
#define COB_READ_WAIT_LOCK
Definition: common.h:820
CB_BINARY_OP_P
#define CB_BINARY_OP_P(x)
Definition: tree.h:937
cb_list_length
int cb_list_length(cb_tree l)
Definition: tree.c:1342
cb_field::depending
cb_tree depending
Definition: tree.h:647
cb_encode_program_id
char * cb_encode_program_id(const char *name)
Definition: typeck.c:1132
cb_build_numeric_literal
cb_tree cb_build_numeric_literal(const int sign, const void *data, const int scale)
Definition: tree.c:1681
cb_build_move_literal
static cb_tree cb_build_move_literal(cb_tree src, cb_tree dst)
Definition: typeck.c:7038
validate_move
int validate_move(cb_tree src, cb_tree dst, const unsigned int is_value)
Definition: typeck.c:6167
cb_build_move_quote
static cb_tree cb_build_move_quote(cb_tree x)
Definition: typeck.c:6904
cb_field::flag_all_debug
unsigned int flag_all_debug
Definition: tree.h:734
cb_emit_if
void cb_emit_if(cb_tree cond, cb_tree stmt1, cb_tree stmt2)
Definition: typeck.c:5665
cb_build_ppointer
cb_tree cb_build_ppointer(cb_tree x)
Definition: typeck.c:1824
evaluate_test
static cb_tree evaluate_test(cb_tree s, cb_tree o)
Definition: typeck.c:5430
CB_FEATURE_C02
#define CB_FEATURE_C02
Definition: tree.h:199
cb_field::file
struct cb_file * file
Definition: tree.h:657
cb_reference::flag_all
unsigned int flag_all
Definition: tree.h:888
cb_check_needs_break
static cb_tree cb_check_needs_break(cb_tree stmt)
Definition: typeck.c:523
cb_program::decimal_index_max
int decimal_index_max
Definition: tree.h:1294
value
strict implicit external value
Definition: warning.def:54
cb_emit_sort_finish
void cb_emit_sort_finish(cb_tree file)
Definition: typeck.c:8356
cb_usage
cb_usage
Definition: tree.h:255
cb_statement::flag_in_debug
unsigned int flag_in_debug
Definition: tree.h:1150
cb_field::offset
int offset
Definition: tree.h:675
CB_FIELD_P
#define CB_FIELD_P(x)
Definition: tree.h:741
cb_tree_common::source_line
int source_line
Definition: tree.h:432
COB_WRITE_PAGE
#define COB_WRITE_PAGE
Definition: common.h:803
CB_ALPHABET_NAME
#define CB_ALPHABET_NAME(x)
Definition: tree.h:550
CB_BUILD_CAST_ADDRESS
#define CB_BUILD_CAST_ADDRESS(x)
Definition: tree.h:1841
CB_INDEX_P
#define CB_INDEX_P(x)
Definition: tree.h:750
cb_field::flag_sign_leading
unsigned int flag_sign_leading
Definition: tree.h:704
cb_check_data_incompat
static void cb_check_data_incompat(cb_tree x)
Definition: typeck.c:719
cb_emit_accept_day
void cb_emit_accept_day(cb_tree var)
Definition: typeck.c:4530
cb_emit_get_environment
void cb_emit_get_environment(cb_tree envvar, cb_tree envval)
Definition: typeck.c:4575
cobc_parse_free
void cobc_parse_free(void *prevptr)
Definition: cobc.c:885
cb_field::flag_is_pdiv_parm
unsigned int flag_is_pdiv_parm
Definition: tree.h:724
VALUE
#define VALUE(offset)
Definition: typeck.c:71
cb_emit_write
void cb_emit_write(cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
Definition: typeck.c:8604
CB_SIZE_1
#define CB_SIZE_1
Definition: tree.h:49
_
#define _(s)
Definition: cobcrun.c:59
cb_emit_start
void cb_emit_start(cb_tree file, cb_tree op, cb_tree key, cb_tree keylen)
Definition: typeck.c:8414
system_table::syst_params
const int syst_params
Definition: typeck.c:48
cb_list_system
void cb_list_system(void)
Definition: typeck.c:833
cb_define_switch_name
cb_tree cb_define_switch_name(cb_tree name, cb_tree sname, const int flag)
Definition: typeck.c:1228
lookup_system_name
cb_tree lookup_system_name(const char *name)
Definition: reserved.c:2860
cb_field
Definition: tree.h:643
unlikely
#define unlikely(x)
Definition: common.h:437
CB_CALL_BY_VALUE
#define CB_CALL_BY_VALUE
Definition: tree.h:46
cb_build_length_1
static cb_tree cb_build_length_1(cb_tree x)
Definition: typeck.c:1696
cb_debug_sub_1
cb_tree cb_debug_sub_1
Definition: typeck.c:85
CB_DEVICE_SYSIN
#define CB_DEVICE_SYSIN
Definition: tree.h:153
cb_build_direct
cb_tree cb_build_direct(const char *str, const unsigned int flagnl)
Definition: tree.c:1553
cb_program::cb_call_params
cb_tree cb_call_params
Definition: tree.h:1267
decimal_free
static void decimal_free(void)
Definition: typeck.c:3251
decimal_alloc
static cb_tree decimal_alloc(void)
Definition: typeck.c:3229
cb_build_tallying_all
cb_tree cb_build_tallying_all(void)
Definition: typeck.c:5874
cb_validate_program_body
void cb_validate_program_body(struct cb_program *prog)
Definition: typeck.c:2554
cb_alphabet_name::high_val_char
int high_val_char
Definition: tree.h:545
CB_BUILD_FUNCALL_2
#define CB_BUILD_FUNCALL_2(f, a1, a2)
Definition: tree.h:1803
cb_field::flag_no_init
unsigned int flag_no_init
Definition: tree.h:727
CB_BUILD_FUNCALL_0
#define CB_BUILD_FUNCALL_0(f)
Definition: tree.h:1795
cb_emit_delete_file
void cb_emit_delete_file(cb_tree file)
Definition: typeck.c:5076
CB_FEATURE_C11
#define CB_FEATURE_C11
Definition: tree.h:208
CB_CHAIN
#define CB_CHAIN(x)
Definition: tree.h:1194
CB_FEATURE_C03
#define CB_FEATURE_C03
Definition: tree.h:200
cb_emit_cancel
void cb_emit_cancel(cb_tree prog)
Definition: typeck.c:4977
cb_literal::scale
int scale
Definition: tree.h:595
cb_int_hex
cb_tree cb_int_hex(const int n)
Definition: tree.c:1514
cb_binary_op::op
int op
Definition: tree.h:932
NULL
EC ARGUMENT EC EC BOUND EC BOUND EC BOUND EC BOUND TABLE EC DATA EC DATA EC DATA PTR NULL
Definition: exception.def:95
CB_TREE_TAG
#define CB_TREE_TAG(x)
Definition: tree.h:441
expr_index
static int expr_index
Definition: typeck.c:105
COB_WRITE_CHANNEL
#define COB_WRITE_CHANNEL
Definition: common.h:804
cb_build_write_advancing_mnemonic
cb_tree cb_build_write_advancing_mnemonic(cb_tree pos, cb_tree mnemonic)
Definition: typeck.c:8701
cb_int4
cb_tree cb_int4
Definition: tree.c:137
cb_reference::offset
cb_tree offset
Definition: tree.h:878
sign
if sign
Definition: flag.def:42
cb_field::flag_indexed_by
unsigned int flag_indexed_by
Definition: tree.h:721
cb_build_move_high
static cb_tree cb_build_move_high(cb_tree x)
Definition: typeck.c:6866
system_table
Definition: codegen.c:65
COBC_ABORT
#define COBC_ABORT()
Definition: cobc.h:61
cb_emit_accept_line_or_col
void cb_emit_accept_line_or_col(cb_tree var, const int l_or_c)
Definition: typeck.c:4476
cb_build_const_length
cb_tree cb_build_const_length(cb_tree x)
Definition: typeck.c:1730
cb_optim
cb_optim
Definition: cobc.h:266
valid_screen_pos
static int valid_screen_pos(cb_tree pos)
Definition: typeck.c:4289
cb_program::cb_return_code
cb_tree cb_return_code
Definition: tree.h:1265
cb_chk_num_cond
static int cb_chk_num_cond(cb_tree x, cb_tree y)
Definition: typeck.c:3668
cb_binary_op
Definition: tree.h:928
cb_attr_struct::timeout
cb_tree timeout
Definition: tree.h:1127
system_table::syst_name
const char *const syst_name
Definition: typeck.c:47
cb_emit_alter
void cb_emit_alter(cb_tree source, cb_tree target)
Definition: typeck.c:4733
cb_build_div
static cb_tree cb_build_div(cb_tree v, cb_tree n, cb_tree round_opt)
Definition: typeck.c:3390
cb_int0
cb_tree cb_int0
Definition: tree.c:133
CB_STATEMENT
#define CB_STATEMENT(x)
Definition: tree.h:1155
f1
cob_field f1
Definition: cobxref.c.l.h:54
CB_NAME
#define CB_NAME(x)
Definition: tree.h:904
hexval
static const unsigned char hexval[]
Definition: typeck.c:109
cb_build_replacing_leading
cb_tree cb_build_replacing_leading(cb_tree x, cb_tree y, cb_tree l)
Definition: typeck.c:5933
cb_report::page_counter
cb_tree page_counter
Definition: tree.h:1216
cb_field::count
int count
Definition: tree.h:680
cb_field::flag_occurs
unsigned int flag_occurs
Definition: tree.h:702
cb_field::flag_invalid
unsigned int flag_invalid
Definition: tree.h:716
cb_build_cast_llint
cb_tree cb_build_cast_llint(const cb_tree val)
Definition: tree.c:2975
CB_REFERENCE
#define CB_REFERENCE(x)
Definition: tree.h:901
output_screen_from
static void output_screen_from(struct cb_field *p, const unsigned int sisters)
Definition: typeck.c:4199
cb_program::alphabet_name_list
cb_tree alphabet_name_list
Definition: tree.h:1256
COB_ORG_RELATIVE
#define COB_ORG_RELATIVE
Definition: common.h:744
cb_one
cb_tree cb_one
Definition: tree.c:126
CB_BUILD_FUNCALL_8
#define CB_BUILD_FUNCALL_8(f, a1, a2, a3, a4, a5, a6, a7, a8)
Definition: tree.h:1827
cb_alphabet_name::values
int values[256]
Definition: tree.h:546
cb_field::flag_binary_swap
unsigned int flag_binary_swap
Definition: tree.h:707
CB_BEFORE
#define CB_BEFORE
Definition: tree.h:25
COB_SCREEN_TYPE_ATTRIBUTE
#define COB_SCREEN_TYPE_ATTRIBUTE
Definition: common.h:930
cb_emit_accept_arg_number
void cb_emit_accept_arg_number(cb_tree var)
Definition: typeck.c:4596
cb_class
cb_class
Definition: tree.h:213
cb_int3
cb_tree cb_int3
Definition: tree.c:136
cb_cast
Definition: tree.h:956
cb_key::dir
int dir
Definition: tree.h:640
cb_build_expr
cb_tree cb_build_expr(cb_tree list)
Definition: typeck.c:3136
redefinition_error
void redefinition_error(cb_tree x)
Definition: error.c:284
cb_fits_int
int cb_fits_int(const cb_tree x)
Definition: tree.c:914
cb_build_display_name
cb_tree cb_build_display_name(cb_tree x)
Definition: typeck.c:5362
cb_program::cb_sort_return
cb_tree cb_sort_return
Definition: tree.h:1266
COB_STORE_KEEP_ON_OVERFLOW
#define COB_STORE_KEEP_ON_OVERFLOW
Definition: common.h:868
cb_emit_set_true
void cb_emit_set_true(cb_tree l)
Definition: typeck.c:8139
CB_LOCALE_NAME_P
#define CB_LOCALE_NAME_P(x)
Definition: tree.h:575
cb_build_debug_call
cb_tree cb_build_debug_call(struct cb_label *target)
Definition: tree.c:1590
cb_alter_id::next
struct cb_alter_id * next
Definition: tree.h:760
CB_CONV_STATIC_LINK
#define CB_CONV_STATIC_LINK
Definition: tree.h:132
cb_build_length
cb_tree cb_build_length(cb_tree x)
Definition: typeck.c:1781
value_has_picture_clause
static COB_INLINE COB_A_INLINE int value_has_picture_clause(cb_tree pos)
Definition: typeck.c:4268
cb_int
cb_tree cb_int(const int n)
Definition: tree.c:1488
cb_statement::file
cb_tree file
Definition: tree.h:1140
COB_ACCESS_SEQUENTIAL
#define COB_ACCESS_SEQUENTIAL
Definition: common.h:751
cb_emit_sort_input
void cb_emit_sort_input(cb_tree proc)
Definition: typeck.c:8309
decimal_assign
static void decimal_assign(cb_tree x, cb_tree d, cb_tree round_opt)
Definition: typeck.c:3361
cb_file::sharing
cb_tree sharing
Definition: tree.h:825
cb_emit_sort_using
void cb_emit_sort_using(cb_tree file, cb_tree l)
Definition: typeck.c:8293
cb_build_move_space
static cb_tree cb_build_move_space(cb_tree x)
Definition: typeck.c:6827
CB_FILE_P
#define CB_FILE_P(x)
Definition: tree.h:859
cb_field::size
int size
Definition: tree.h:672
cb_file
Definition: tree.h:818
cb_emit_rollback
void cb_emit_rollback(void)
Definition: typeck.c:7844
COB_READ_IGNORE_LOCK
#define COB_READ_IGNORE_LOCK
Definition: common.h:821
CB_BUILD_CAST_ADDR_OF_ADDR
#define CB_BUILD_CAST_ADDR_OF_ADDR(x)
Definition: tree.h:1842
CB_ALPHABET_CUSTOM
#define CB_ALPHABET_CUSTOM
Definition: tree.h:110
cb_literal::data
unsigned char * data
Definition: tree.h:593
cb_build_reference
cb_tree cb_build_reference(const char *name)
Definition: tree.c:2572
bin_compare_funcs
static const struct optim_table bin_compare_funcs[]
Definition: typeck.c:308
cobc_init_typeck
void cobc_init_typeck(void)
Definition: typeck.c:8747
finalize_file
void finalize_file(struct cb_file *f, struct cb_field *records)
Definition: tree.c:2409
cb_emit_set_false
void cb_emit_set_false(cb_tree l)
Definition: typeck.c:8171
cb_field::flag_any_numeric
unsigned int flag_any_numeric
Definition: tree.h:736
cb_validate_program_data
void cb_validate_program_data(struct cb_program *prog)
Definition: typeck.c:2344
build_cond_88
static cb_tree build_cond_88(cb_tree x)
Definition: typeck.c:3519
cb_field::rename_thru
struct cb_field * rename_thru
Definition: tree.h:655
cb_error_node
cb_tree cb_error_node
Definition: tree.c:140
cb_field::screen_to
cb_tree screen_to
Definition: tree.h:666
COB_WRITE_BEFORE
#define COB_WRITE_BEFORE
Definition: common.h:806
CB_ASSIGN_MF
#define CB_ASSIGN_MF
Definition: cobc.h:77
COB_OPEN_I_O
#define COB_OPEN_I_O
Definition: common.h:786
COB_FOLD_LOWER
#define COB_FOLD_LOWER
Definition: common.h:587
cb_alter_id
Definition: tree.h:759
CB_INTRINSIC_P
#define CB_INTRINSIC_P(x)
Definition: tree.h:1002
cb_field::parent
struct cb_field * parent
Definition: tree.h:651
CB_BUILD_FUNCALL_10
#define CB_BUILD_FUNCALL_10(f, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
Definition: tree.h:1835
cb_emit_divide
void cb_emit_divide(cb_tree dividend, cb_tree divisor, cb_tree quotient, cb_tree remainder)
Definition: typeck.c:5399
warning_destination
static void warning_destination(cb_tree x)
Definition: typeck.c:5969
cb_binary_op::y
cb_tree y
Definition: tree.h:931
gen_screen_ptr
unsigned int gen_screen_ptr
Definition: tree.c:146
value_pic_has_no_scale
static COB_INLINE COB_A_INLINE int value_pic_has_no_scale(cb_tree pos)
Definition: typeck.c:4274
current_paragraph
struct cb_label * current_paragraph
Definition: parser.c:171
cobc_strdup
void * cobc_strdup(const char *dupstr)
Definition: cobc.c:669
cb_program::class_name_list
cb_tree class_name_list
Definition: tree.h:1258
cb_emit_close
void cb_emit_close(cb_tree file, cb_tree opt)
Definition: typeck.c:4988
CB_DEVICE_CONSOLE
#define CB_DEVICE_CONSOLE
Definition: tree.h:156
cb_field::flag_blank_zero
unsigned int flag_blank_zero
Definition: tree.h:705
cb_expr_shift_class
static void cb_expr_shift_class(const char *name)
Definition: typeck.c:2950
CB_BUILD_CHAIN
#define CB_BUILD_CHAIN(x, y)
Definition: tree.h:1852
cb_reference::flag_receiving
unsigned int flag_receiving
Definition: tree.h:887
CB_GOTO_P
#define CB_GOTO_P(x)
Definition: tree.h:1080
cb_build_unstring_into
cb_tree cb_build_unstring_into(cb_tree name, cb_tree delimiter, cb_tree count)
Definition: typeck.c:8587
valid_screen_pos_type
static int valid_screen_pos_type(cb_tree pos)
Definition: typeck.c:4280
cb_emit_accept_time
void cb_emit_accept_time(cb_tree var)
Definition: typeck.c:4557
cb_error
void cb_error(const char *,...) COB_A_FORMAT12
Definition: error.c:98
cb_emit_arithmetic
void cb_emit_arithmetic(cb_tree vars, const int op, cb_tree val)
Definition: typeck.c:3465
expr_node
Definition: typeck.c:56
cb_build_move_low
static cb_tree cb_build_move_low(cb_tree x)
Definition: typeck.c:6885
cb_build_address
cb_tree cb_build_address(cb_tree x)
Definition: typeck.c:1357
cb_cast::cast_type
enum cb_cast_type cast_type
Definition: tree.h:959
emit_screen_display
static void emit_screen_display(const cb_tree x, const cb_tree pos)
Definition: typeck.c:5192
cb_file::access_mode
int access_mode
Definition: tree.h:845
decimal_compute
static void decimal_compute(const int op, cb_tree x, cb_tree y)
Definition: typeck.c:3257
cb_report
Definition: tree.h:1210
cb_emit_sort_init
void cb_emit_sort_init(cb_tree name, cb_tree keys, cb_tree col)
Definition: typeck.c:8237
cb_gen_field_accept
static void cb_gen_field_accept(cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, cb_tree timeout, cb_tree prompt, cb_tree size_is, int dispattrs)
Definition: typeck.c:4316
cb_program::program_name
const char * program_name
Definition: tree.h:1243
cb_emit_set_on_off
void cb_emit_set_on_off(cb_tree l, cb_tree flag)
Definition: typeck.c:8124
COB_SCREEN_ERASE_EOS
#define COB_SCREEN_ERASE_EOS
Definition: common.h:905
cb_build_optim_cond
static cb_tree cb_build_optim_cond(struct cb_binary_op *p)
Definition: typeck.c:3558
cb_emit_command_line
void cb_emit_command_line(cb_tree value)
Definition: typeck.c:5133
COB_A_INLINE
#define COB_A_INLINE
Definition: common.h:440
cb_program::label_list
cb_tree label_list
Definition: tree.h:1254
cb_emit_initialize
void cb_emit_initialize(cb_tree vars, cb_tree fillinit, cb_tree value, cb_tree replacing, cb_tree def)
Definition: typeck.c:5682
CB_FEATURE_C04
#define CB_FEATURE_C04
Definition: tree.h:201
CB_FEATURE_C12
#define CB_FEATURE_C12
Definition: tree.h:209
cb_debug_sub_3
cb_tree cb_debug_sub_3
Definition: typeck.c:87
cb_file::file_status
cb_tree file_status
Definition: tree.h:824
cb_build_alter
cb_tree cb_build_alter(const cb_tree source, const cb_tree target)
Definition: tree.c:3101
cb_check_integer_value
static cb_tree cb_check_integer_value(cb_tree x)
Definition: typeck.c:666
line
if fold fold static computed alternate extra correct stack on syntax debugging line
Definition: flag.def:90
CB_LIST_P
#define CB_LIST_P(x)
Definition: tree.h:1190
cb_file::flag_fl_debug
unsigned int flag_fl_debug
Definition: tree.h:854
current_program
struct cb_program * current_program
Definition: parser.c:168
CB_ADD_TO_CHAIN
#define CB_ADD_TO_CHAIN(x, y)
Definition: tree.h:1854
cb_alphabet_name::low_val_char
int low_val_char
Definition: tree.h:544
CB_BUILD_STRING0
#define CB_BUILD_STRING0(str)
Definition: tree.h:1849
cb_alt_key::key
cb_tree key
Definition: tree.h:813
cb_null
cb_tree cb_null
Definition: tree.c:124
cb_build_initialize
cb_tree cb_build_initialize(const cb_tree var, const cb_tree val, const cb_tree rep, const unsigned int def, const unsigned int is_statement, const unsigned int no_filler_init)
Definition: tree.c:3028
cb_program::collating_sequence
cb_tree collating_sequence
Definition: tree.h:1284
COB_SCREEN_NO_DISP
#define COB_SCREEN_NO_DISP
Definition: common.h:921
cb_emit_accept_day_of_week
void cb_emit_accept_day_of_week(cb_tree var)
Definition: typeck.c:4548
cb_program::classification
cb_tree classification
Definition: tree.h:1285
CB_EXCEPTION_ENABLE
#define CB_EXCEPTION_ENABLE(id)
Definition: cobc.h:243
cb_label::alter_gotos
struct cb_alter_id * alter_gotos
Definition: tree.h:772
cb_validate_collating
static void cb_validate_collating(struct cb_program *prog)
Definition: typeck.c:1864
cb_picture::have_sign
cob_u32_t have_sign
Definition: tree.h:627
cb_program::cursor_pos
cb_tree cursor_pos
Definition: tree.h:1286
cb_build_continue
cb_tree cb_build_continue(void)
Definition: tree.c:3214
cb_build_write_advancing_page
cb_tree cb_build_write_advancing_page(cb_tree pos)
Definition: typeck.c:8738
cb_report::name
const char * name
Definition: tree.h:1212
cb_field::flag_sign_separate
unsigned int flag_sign_separate
Definition: tree.h:703
cb_emit_search
void cb_emit_search(cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
Definition: typeck.c:7965
cb_high
cb_tree cb_high
Definition: tree.c:129
cb_build_registers
void cb_build_registers(void)
Definition: typeck.c:1051
expr_chk_cond
static int expr_chk_cond(cb_tree expr_1, cb_tree expr_2)
Definition: typeck.c:2731
CB_REPORT
#define CB_REPORT(x)
Definition: tree.h:1228
cb_category_is_alpha
int cb_category_is_alpha(cb_tree x)
Definition: tree.c:843
cb_file::record
struct cb_field * record
Definition: tree.h:829
cb_field::mem_offset
int mem_offset
Definition: tree.h:681
cb_file::organization
int organization
Definition: tree.h:844
cb_key::key
cb_tree key
Definition: tree.h:637
CB_WORD_COUNT
#define CB_WORD_COUNT(x)
Definition: tree.h:905
cb_binary_op::x
cb_tree x
Definition: tree.h:930
cb_attr_struct::prompt
cb_tree prompt
Definition: tree.h:1128
cb_warning
void cb_warning(const char *,...) COB_A_FORMAT12
Definition: error.c:87
cb_build_assign
cb_tree cb_build_assign(const cb_tree var, const cb_tree val)
Definition: tree.c:3014
initialized
static size_t initialized
Definition: typeck.c:102
CB_LIST_INIT
#define CB_LIST_INIT(x)
Definition: tree.h:1851
cb_emit_rewrite
void cb_emit_rewrite(cb_tree record, cb_tree from, cb_tree lockopt)
Definition: typeck.c:7707
build_decimal_assign
static cb_tree build_decimal_assign(cb_tree vars, const int op, cb_tree val)
Definition: typeck.c:3412
cb_expr_shift_sign
static void cb_expr_shift_sign(const int op)
Definition: typeck.c:2930
CB_BINARY_OP
#define CB_BINARY_OP(x)
Definition: tree.h:936
cb_emit_setenv
void cb_emit_setenv(cb_tree x, cb_tree y)
Definition: typeck.c:8013
cb_system_name::token
int token
Definition: tree.h:583
COB_ORG_SORT
#define COB_ORG_SORT
Definition: common.h:746
CB_ALPHABET_NAME_P
#define CB_ALPHABET_NAME_P(x)
Definition: tree.h:551
cb_reference::subs
cb_tree subs
Definition: tree.h:877
CB_SIZES_INT_UNSIGNED
#define CB_SIZES_INT_UNSIGNED(x)
Definition: tree.h:1200
cb_label
Definition: tree.h:764
cb_exp_line
int cb_exp_line
Definition: parser.c:174
cb_debug_contents
cb_tree cb_debug_contents
Definition: typeck.c:88
COB_ACCESS_RANDOM
#define COB_ACCESS_RANDOM
Definition: common.h:753
cb_program::all_procedure
struct cb_label * all_procedure
Definition: tree.h:1289
COBC_DUMB_ABORT
#define COBC_DUMB_ABORT()
Definition: cobc.h:62
cb_statement::flag_callback
unsigned int flag_callback
Definition: tree.h:1152
cob_put_sign_ascii
static void cob_put_sign_ascii(unsigned char *p)
Definition: common.c:699
build_store_option
static cb_tree build_store_option(cb_tree x, cb_tree round_opt)
Definition: typeck.c:3193
cb_list_map
void cb_list_map(cb_tree(*func)(cb_tree x), cb_tree l)
Definition: tree.c:1357
COB_ORG_LINE_SEQUENTIAL
#define COB_ORG_LINE_SEQUENTIAL
Definition: common.h:743
cb_program::exec_list
cb_tree exec_list
Definition: tree.h:1253
cb_emit_inspect
void cb_emit_inspect(cb_tree var, cb_tree body, cb_tree replacing, const unsigned int replconv)
Definition: typeck.c:5805
cb_statement::null_check
cb_tree null_check
Definition: tree.h:1144
cb_build_replacing_first
cb_tree cb_build_replacing_first(cb_tree x, cb_tree y, cb_tree l)
Definition: typeck.c:5940
cb_statement::handler3
cb_tree handler3
Definition: tree.h:1143
cb_check_field_debug
void cb_check_field_debug(cb_tree fld)
Definition: typeck.c:904
cb_program::working_storage
struct cb_field * working_storage
Definition: tree.h:1276
cb_emit_continue
void cb_emit_continue(void)
Definition: typeck.c:5031
START_STACK_SIZE
#define START_STACK_SIZE
Definition: typeck.c:69
cb_field::memory_size
int memory_size
Definition: tree.h:674
build_evaluate
static void build_evaluate(cb_tree subject_list, cb_tree case_list, cb_tree labid)
Definition: typeck.c:5493
cb_build_cond
cb_tree cb_build_cond(cb_tree x)
Definition: typeck.c:3737
suppress_warn
size_t suppress_warn
Definition: typeck.c:90
emit_corresponding
static unsigned int emit_corresponding(cb_tree(*func)(cb_tree f1, cb_tree f2, cb_tree f3), cb_tree x1, cb_tree x2, cb_tree opt)
Definition: typeck.c:4093
CB_BUILD_CAST_LENGTH
#define CB_BUILD_CAST_LENGTH(x)
Definition: tree.h:1843
bin_set_funcs
static const struct optim_table bin_set_funcs[]
Definition: typeck.c:289
COB_STORE_TRUNC_ON_OVERFLOW
#define COB_STORE_TRUNC_ON_OVERFLOW
Definition: common.h:869
cb_emit_stop_run
void cb_emit_stop_run(cb_tree x)
Definition: typeck.c:8482
cb_build_perform
cb_tree cb_build_perform(const enum cb_perform_type type)
Definition: tree.c:3149
cb_statement::debug_nodups
cb_tree debug_nodups
Definition: tree.h:1146
cb_alt_key
Definition: tree.h:811
cb_emit_env_name
void cb_emit_env_name(cb_tree value)
Definition: typeck.c:5106
cb_alter_id::goto_id
int goto_id
Definition: tree.h:761
CB_FEATURE_C05
#define CB_FEATURE_C05
Definition: tree.h:202
expr_stack
static struct expr_node * expr_stack
Definition: typeck.c:107
CB_CLASS_NAME
#define CB_CLASS_NAME(x)
Definition: tree.h:562
cb_field::index_qual
struct cb_field * index_qual
Definition: tree.h:656
cb_cast::val
cb_tree val
Definition: tree.h:958
cb_tree_class
enum cb_class cb_tree_class(cb_tree x)
Definition: tree.c:836
system_table::syst_name
const char * syst_name
Definition: codegen.c:66
cb_reference::length
cb_tree length
Definition: tree.h:879
cb_emit
#define cb_emit(x)
Definition: typeck.c:75
optimize_defs
cob_u32_t optimize_defs[COB_OPTIM_MAX]
Definition: cobc.c:182
current_section
struct cb_label * current_section
Definition: parser.c:170
cb_build_debug
cb_tree cb_build_debug(const cb_tree target, const char *str, const cb_tree fld)
Definition: tree.c:1566
CB_BUILD_FUNCALL_5
#define CB_BUILD_FUNCALL_5(f, a1, a2, a3, a4, a5)
Definition: tree.h:1815
cb_depend_check
cb_tree cb_depend_check
Definition: field.c:36
cb_build_converting
cb_tree cb_build_converting(cb_tree x, cb_tree y, cb_tree l)
Definition: typeck.c:5954
cb_emit_set_attribute
void cb_emit_set_attribute(cb_tree x, const int val_on, const int val_off)
Definition: typeck.c:8207
cb_validate_field
void cb_validate_field(struct cb_field *f)
Definition: field.c:1338
COB_READ_NEXT
#define COB_READ_NEXT
Definition: common.h:813
COB_SCREEN_TYPE_GROUP
#define COB_SCREEN_TYPE_GROUP
Definition: common.h:927
cobc_check_valid_name
size_t cobc_check_valid_name(const char *name, const unsigned int prechk)
Definition: cobc.c:1142
cb_file::key
cb_tree key
Definition: tree.h:826
cb_validate_list
static size_t cb_validate_list(cb_tree l)
Definition: typeck.c:581
COB_FOLD_UPPER
#define COB_FOLD_UPPER
Definition: common.h:586
cb_list_reverse
cb_tree cb_list_reverse(cb_tree l)
Definition: tree.c:1327
COB_WRITE_LOCK
#define COB_WRITE_LOCK
Definition: common.h:808
cobc_cs_check
unsigned int cobc_cs_check
Definition: parser.c:182
cb_emit_accept_name
void cb_emit_accept_name(cb_tree var, cb_tree name)
Definition: typeck.c:4635
cb_build_tallying_trailing
cb_tree cb_build_tallying_trailing(void)
Definition: typeck.c:5896
cb_statement::handler1
cb_tree handler1
Definition: tree.h:1141
cb_field::redefines
struct cb_field * redefines
Definition: tree.h:654
cb_emit_return
void cb_emit_return(cb_tree ref, cb_tree into)
Definition: typeck.c:7818
cb_attr_struct::dispattrs
int dispattrs
Definition: tree.h:1130
cb_emit_accept_arg_value
void cb_emit_accept_arg_value(cb_tree var)
Definition: typeck.c:4605
expr_prio
static unsigned char expr_prio[256]
Definition: typeck.c:199
cb_field::values
cb_tree values
Definition: tree.h:648
cb_init_tallying
void cb_init_tallying(void)
Definition: typeck.c:5849
cb_build_cast_int
cb_tree cb_build_cast_int(const cb_tree val)
Definition: tree.c:2964
cb_emit_reset_trace
void cb_emit_reset_trace(void)
Definition: typeck.c:7699
cb_build_move_copy
static cb_tree cb_build_move_copy(cb_tree src, cb_tree dst)
Definition: typeck.c:6739
cb_get_long_long
cob_s64_t cb_get_long_long(const cb_tree x)
Definition: tree.c:1175
CB_FEATURE_C06
#define CB_FEATURE_C06
Definition: tree.h:203
initialize_attrs
static void initialize_attrs(const struct cb_attr_struct *const attr_ptr, cb_tree *const fgc, cb_tree *const bgc, cb_tree *const scroll, cb_tree *const size_is, int *const dispattrs)
Definition: typeck.c:5152
cb_emit_accept_mnemonic
void cb_emit_accept_mnemonic(cb_tree var, cb_tree mnemonic)
Definition: typeck.c:4614
cb_emit_sort_giving
void cb_emit_sort_giving(cb_tree file, cb_tree l)
Definition: typeck.c:8319
cb_emit_arg_number
void cb_emit_arg_number(cb_tree value)
Definition: typeck.c:5124
cb_literal::size
cob_u32_t size
Definition: tree.h:594
f3
cob_field f3
Definition: cobxref.c.l.h:56
CB_FEATURE_C08
#define CB_FEATURE_C08
Definition: tree.h:205
cb_build_tallying_characters
cb_tree cb_build_tallying_characters(cb_tree l)
Definition: typeck.c:5863
expr_reduce
static int expr_reduce(int token)
Definition: typeck.c:2788
inspect_data
static cb_tree inspect_data
Definition: typeck.c:97
search_set_keys
static unsigned int search_set_keys(struct cb_field *f, cb_tree x)
Definition: typeck.c:7852
cb_file::flag_finalized
unsigned int flag_finalized
Definition: tree.h:849
CB_INTEGER_P
#define CB_INTEGER_P(x)
Definition: tree.h:523
cb_expr_finish
static cb_tree cb_expr_finish(void)
Definition: typeck.c:3108
inspect_func
static const char * inspect_func
Definition: typeck.c:96
cb_file::alt_key_list
struct cb_alt_key * alt_key_list
Definition: tree.h:827
cb_emit_set_to
void cb_emit_set_to(cb_tree vars, cb_tree x)
Definition: typeck.c:8019
COB_ASCENDING
#define COB_ASCENDING
Definition: common.h:735
cb_label::id
int id
Definition: tree.h:773
CB_REF_OR_FIELD_P
#define CB_REF_OR_FIELD_P(x)
Definition: tree.h:743
cb_attr_struct::fgc
cb_tree fgc
Definition: tree.h:1124
optim_table
Definition: typeck.c:51
cb_check_numeric_value
cb_tree cb_check_numeric_value(cb_tree x)
Definition: typeck.c:651
cb_build_assignment_name
cb_tree cb_build_assignment_name(struct cb_file *cfile, cb_tree name)
Definition: typeck.c:1276
cb_alphabet_name::alphabet_type
unsigned int alphabet_type
Definition: tree.h:543
check_level_78
struct cb_field * check_level_78(const char *name)
Definition: scanner.c:4858
cb_field::usage
enum cb_usage usage
Definition: tree.h:693
cb_build_inspect_region_start
cb_tree cb_build_inspect_region_start(void)
Definition: typeck.c:5961
cb_statement::flag_merge
unsigned int flag_merge
Definition: tree.h:1151
current_statement
struct cb_statement * current_statement
Definition: parser.c:169
cb_build_binary_op
cb_tree cb_build_binary_op(cb_tree x, const int op, cb_tree y)
Definition: tree.c:2827
cb_emit_accept_command_line
void cb_emit_accept_command_line(cb_tree var)
Definition: typeck.c:4566
cb_file::record_depending
cb_tree record_depending
Definition: tree.h:830
cb_emit_move
void cb_emit_move(cb_tree src, cb_tree dsts)
Definition: typeck.c:7416
cb_build_if
cb_tree cb_build_if(const cb_tree test, const cb_tree stmt1, const cb_tree stmt2, const unsigned int is_if)
Definition: tree.c:3132
cb_build_memset
static cb_tree cb_build_memset(cb_tree x, const int c)
Definition: typeck.c:6726
cb_field::keys
struct cb_key * keys
Definition: tree.h:658
CB_ALPHABET_EBCDIC
#define CB_ALPHABET_EBCDIC
Definition: tree.h:109
likely
#define likely(x)
Definition: common.h:436
cb_field::storage
enum cb_storage storage
Definition: tree.h:692
cob_refer_ascii
static const unsigned char cob_refer_ascii[256]
Definition: typeck.c:206
cb_field::nkeys
int nkeys
Definition: tree.h:682
cb_low
cb_tree cb_low
Definition: tree.c:128
cb_int2
cb_tree cb_int2
Definition: tree.c:135
cb_field_founder
struct cb_field * cb_field_founder(const struct cb_field *f)
Definition: tree.c:2227
cb_expr_init
static void cb_expr_init(void)
Definition: typeck.c:2714
cb_check_numeric_name
static cb_tree cb_check_numeric_name(cb_tree x)
Definition: typeck.c:616
cb_emit_open
void cb_emit_open(cb_tree file, cb_tree mode, cb_tree sharing)
Definition: typeck.c:7461
cb_program::symbolic_char_list
cb_tree symbolic_char_list
Definition: tree.h:1257
cb_build_perform_until
cb_tree cb_build_perform_until(cb_tree condition, cb_tree varying)
Definition: typeck.c:7550
COB_READ_LOCK
#define COB_READ_LOCK
Definition: common.h:817
cb_program::decimal_point
unsigned char decimal_point
Definition: tree.h:1300
cb_build_search_all
static cb_tree cb_build_search_all(cb_tree table, cb_tree cond)
Definition: typeck.c:7923
CB_FIELD
#define CB_FIELD(x)
Definition: tree.h:740
cb_emit_perform
void cb_emit_perform(cb_tree perform, cb_tree body)
Definition: typeck.c:7509
cb_label::flag_first_is_goto
unsigned int flag_first_is_goto
Definition: tree.h:793
cb_build_goto
cb_tree cb_build_goto(const cb_tree target, const cb_tree depending)
Definition: tree.c:3118
cb_program::orig_program_id
char * orig_program_id
Definition: tree.h:1246
COB_MINI_MAX
#define COB_MINI_MAX
Definition: common.h:545
cb_build_replacing_characters
cb_tree cb_build_replacing_characters(cb_tree x, cb_tree l)
Definition: typeck.c:5916
cb_emit_display_omitted
void cb_emit_display_omitted(cb_tree pos, struct cb_attr_struct *attr_ptr)
Definition: typeck.c:5217
cb_reference::word
struct cb_word * word
Definition: tree.h:881
cb_alphabet_name::custom_list
cb_tree custom_list
Definition: tree.h:542
cb_list_add
cb_tree cb_list_add(cb_tree l, cb_tree x)
Definition: tree.c:1315
cb_build_unstring_delimited
cb_tree cb_build_unstring_delimited(cb_tree all, cb_tree value)
Definition: typeck.c:8578
cb_emit_call
void cb_emit_call(cb_tree prog, cb_tree par_using, cb_tree returning, cb_tree on_exception, cb_tree not_on_exception, cb_tree convention)
Definition: typeck.c:4748
cb_statement::handler2
cb_tree handler2
Definition: tree.h:1142
cb_build_identifier
cb_tree cb_build_identifier(cb_tree x, const int subchk)
Definition: typeck.c:1426
cb_class_name::list
cb_tree list
Definition: tree.h:559
cb_field::flag_item_based
unsigned int flag_item_based
Definition: tree.h:713
cb_field::false_88
cb_tree false_88
Definition: tree.h:649