1 /*
2 Copyright (C) 2001-2012, 2014-2020 Free Software Foundation, Inc.
3 Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch,
4 Edward Hart
5
6 This file is part of GnuCOBOL.
7
8 The GnuCOBOL compiler is free software: you can redistribute it
9 and/or modify it under the terms of the GNU General Public License
10 as published by the Free Software Foundation, either version 3 of the
11 License, or (at your option) any later version.
12
13 GnuCOBOL is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
20 */
21
22 %expect 0
23
24 %defines
25 %verbose
26 %error-verbose
27
28 %{
29 #include <config.h>
30
31 #include <stdlib.h>
32 #include <string.h>
33
34 #define COB_IN_PARSER 1
35 #include "cobc.h"
36 #include "tree.h"
37
38 #ifndef _STDLIB_H
39 #define _STDLIB_H 1
40 #endif
41
42 #define YYSTYPE cb_tree
43 #define yyerror(x) cb_error_always ("%s", x)
44
45 #define emit_statement(x) \
46 do { \
47 if (!skip_statements) { \
48 CB_ADD_TO_CHAIN (x, current_program->exec_list); \
49 } \
50 } ONCE_COB
51
52 #define push_expr(type, node) \
53 current_expr = cb_build_list (cb_int (type), node, current_expr)
54
55 /* Statement terminator definitions */
56 #define TERM_NONE 0
57 #define TERM_ACCEPT 1U
58 #define TERM_ADD 2U
59 #define TERM_CALL 3U
60 #define TERM_COMPUTE 4U
61 #define TERM_DELETE 5U
62 #define TERM_DISPLAY 6U
63 #define TERM_DIVIDE 7U
64 #define TERM_EVALUATE 8U
65 #define TERM_IF 9U
66 #define TERM_JSON 10U
67 #define TERM_MODIFY 11U
68 #define TERM_MULTIPLY 12U
69 #define TERM_PERFORM 13U
70 #define TERM_READ 14U
71 #define TERM_RECEIVE 15U
72 #define TERM_RETURN 16U
73 #define TERM_REWRITE 17U
74 #define TERM_SEARCH 18U
75 #define TERM_START 19U
76 #define TERM_STRING 20U
77 #define TERM_SUBTRACT 21U
78 #define TERM_UNSTRING 22U
79 #define TERM_WRITE 23U
80 #define TERM_XML 24U
81 #define TERM_MAX 25U /* Always last entry, used for array size */
82
83 #define TERMINATOR_WARNING(x,z) terminator_warning (x, TERM_##z, #z)
84 #define TERMINATOR_ERROR(x,z) terminator_error (x, TERM_##z, #z)
85 #define TERMINATOR_CLEAR(x,z) terminator_clear (x, TERM_##z)
86
87 /* Defines for duplicate checks */
88 /* Note - We use <= 16 for common item definitions and */
89 /* > 16 for non-common item definitions e.g. REPORT and SCREEN */
90 #define SYN_CLAUSE_1 (1U << 0)
91 #define SYN_CLAUSE_2 (1U << 1)
92 #define SYN_CLAUSE_3 (1U << 2)
93 #define SYN_CLAUSE_4 (1U << 3)
94 #define SYN_CLAUSE_5 (1U << 4)
95 #define SYN_CLAUSE_6 (1U << 5)
96 #define SYN_CLAUSE_7 (1U << 6)
97 #define SYN_CLAUSE_8 (1U << 7)
98 #define SYN_CLAUSE_9 (1U << 8)
99 #define SYN_CLAUSE_10 (1U << 9)
100 #define SYN_CLAUSE_11 (1U << 10)
101 #define SYN_CLAUSE_12 (1U << 11)
102 #define SYN_CLAUSE_13 (1U << 12)
103 #define SYN_CLAUSE_14 (1U << 13)
104 #define SYN_CLAUSE_15 (1U << 14)
105 #define SYN_CLAUSE_16 (1U << 15)
106 #define SYN_CLAUSE_17 (1U << 16)
107 #define SYN_CLAUSE_18 (1U << 17)
108 #define SYN_CLAUSE_19 (1U << 18)
109 #define SYN_CLAUSE_20 (1U << 19)
110 #define SYN_CLAUSE_21 (1U << 20)
111 #define SYN_CLAUSE_22 (1U << 21)
112 #define SYN_CLAUSE_23 (1U << 22)
113 #define SYN_CLAUSE_24 (1U << 23)
114 #define SYN_CLAUSE_25 (1U << 24)
115 #define SYN_CLAUSE_26 (1U << 25)
116 #define SYN_CLAUSE_27 (1U << 26)
117 #define SYN_CLAUSE_28 (1U << 27)
118 #define SYN_CLAUSE_29 (1U << 28)
119 #define SYN_CLAUSE_30 (1U << 29)
120 #define SYN_CLAUSE_31 (1U << 30)
121 #define SYN_CLAUSE_32 (1U << 31)
122
123 #define EVAL_DEPTH 32
124 #define PROG_DEPTH 16
125
126 /* Global variables */
127
128 struct cb_program *current_program = NULL; /* program in parse/syntax check/codegen */
129 struct cb_statement *current_statement = NULL;
130 struct cb_label *current_section = NULL;
131 struct cb_label *current_paragraph = NULL;
132 struct cb_field *external_defined_fields_ws;
133 struct cb_field *external_defined_fields_global;
134 cb_tree defined_prog_list = NULL;
135 int cb_exp_line = 0;
136
137 cb_tree cobc_printer_node = NULL;
138 int functions_are_all = 0;
139 int non_const_word = 0;
140 int suppress_data_exceptions = 0;
141 unsigned int cobc_repeat_last_token = 0;
142 unsigned int cobc_in_id = 0;
143 unsigned int cobc_in_procedure = 0;
144 unsigned int cobc_in_repository = 0;
145 unsigned int cobc_force_literal = 0;
146 unsigned int cobc_cs_check = 0;
147 unsigned int cobc_allow_program_name = 0;
148 unsigned int cobc_in_xml_generate_body = 0;
149 unsigned int cobc_in_json_generate_body = 0;
150
151 /* Local variables */
152
153 enum tallying_phrase {
154 NO_PHRASE,
155 FOR_PHRASE,
156 CHARACTERS_PHRASE,
157 ALL_LEADING_TRAILING_PHRASES,
158 VALUE_REGION_PHRASE
159 };
160
161 enum key_clause_type {
162 NO_KEY,
163 RECORD_KEY,
164 RELATIVE_KEY
165 };
166
167 static cb_tree current_expr;
168 static struct cb_field *current_field;
169 static struct cb_field *control_field;
170 static struct cb_field *description_field;
171 static struct cb_file *current_file;
172 static struct cb_cd *current_cd;
173 static struct cb_report *current_report;
174 static struct cb_report *report_instance;
175 static struct cb_key_component *key_component_list;
176
177 static struct cb_file *linage_file;
178 static cb_tree next_label_list;
179
180 static const char *stack_progid[PROG_DEPTH];
181
182 static enum cb_storage current_storage;
183
184 static cb_tree perform_stack;
185 static cb_tree qualifier;
186 static cb_tree keys_list;
187
188 static cb_tree save_tree;
189 static cb_tree start_tree;
190
191 static unsigned int check_unreached;
192 static unsigned int within_typedef_definition;
193 static unsigned int in_declaratives;
194 static unsigned int in_debugging;
195 static unsigned int current_linage;
196 static unsigned int report_count;
197 static unsigned int first_prog;
198 static unsigned int setup_from_identification;
199 static unsigned int use_global_ind;
200 static unsigned int same_area;
201 static unsigned int inspect_keyword;
202 static unsigned int main_flag_set;
203 static int next_label_id;
204 static int eval_level;
205 static int eval_inc;
206 static int eval_inc2;
207 static int depth;
208 static int first_nested_program;
209 static int call_mode;
210 static int size_mode;
211 static cob_flags_t set_attr_val_on;
212 static cob_flags_t set_attr_val_off;
213 static cob_flags_t check_duplicate;
214 static cob_flags_t check_on_off_duplicate;
215 static cob_flags_t check_pic_duplicate;
216 static cob_flags_t check_line_col_duplicate;
217 static unsigned int skip_statements;
218 static unsigned int start_debug;
219 static unsigned int save_debug;
220 static unsigned int needs_field_debug;
221 static unsigned int needs_debug_item;
222 static unsigned int env_div_seen;
223 static cob_flags_t header_check;
224 static unsigned int call_nothing;
225 static enum tallying_phrase previous_tallying_phrase;
226 static cb_tree default_rounded_mode;
227 static enum key_clause_type key_type;
228
229 static int ext_dyn_specified;
230 static enum cb_assign_device assign_device;
231
232 static enum cb_display_type display_type;
233 static int is_first_display_item;
234 static cb_tree advancing_value;
235 static cb_tree upon_value;
236 static cb_tree line_column;
237
238 static unsigned int exhibit_changed;
239 static unsigned int exhibit_named;
240
241 static cb_tree ml_suppress_list;
242 static cb_tree xml_encoding;
243 static int with_xml_dec;
244 static int with_attrs;
245
246 static cb_tree alphanumeric_collation;
247 static cb_tree national_collation;
248
249 static enum cb_ml_suppress_category ml_suppress_category;
250
251 static int term_array[TERM_MAX];
252 static cb_tree eval_check[EVAL_DEPTH][EVAL_DEPTH];
253
254 static const char *backup_source_file = NULL;
255 static int backup_source_line = 0;
256
257 /* Defines for header presence */
258
259 #define COBC_HD_ENVIRONMENT_DIVISION (1U << 0)
260 #define COBC_HD_CONFIGURATION_SECTION (1U << 1)
261 #define COBC_HD_SPECIAL_NAMES (1U << 2)
262 #define COBC_HD_INPUT_OUTPUT_SECTION (1U << 3)
263 #define COBC_HD_FILE_CONTROL (1U << 4)
264 #define COBC_HD_I_O_CONTROL (1U << 5)
265 #define COBC_HD_DATA_DIVISION (1U << 6)
266 #define COBC_HD_FILE_SECTION (1U << 7)
267 #define COBC_HD_WORKING_STORAGE_SECTION (1U << 8)
268 #define COBC_HD_LOCAL_STORAGE_SECTION (1U << 9)
269 #define COBC_HD_LINKAGE_SECTION (1U << 10)
270 #define COBC_HD_COMMUNICATION_SECTION (1U << 11)
271 #define COBC_HD_REPORT_SECTION (1U << 12)
272 #define COBC_HD_SCREEN_SECTION (1U << 13)
273 #define COBC_HD_PROCEDURE_DIVISION (1U << 14)
274 #define COBC_HD_PROGRAM_ID (1U << 15)
275 #define COBC_HD_SOURCE_COMPUTER (1U << 16)
276 #define COBC_HD_OBJECT_COMPUTER (1U << 17)
277 #define COBC_HD_REPOSITORY (1U << 18)
278
279 /* Static functions */
280
281 static void
begin_statement(const char * name,const unsigned int term)282 begin_statement (const char *name, const unsigned int term)
283 {
284 if (check_unreached) {
285 cb_warning (cb_warn_unreachable, _("unreachable statement '%s'"), name);
286 }
287 current_paragraph->flag_statement = 1;
288 current_statement = cb_build_statement (name);
289 CB_TREE (current_statement)->source_file = cb_source_file;
290 CB_TREE (current_statement)->source_line = cb_source_line;
291 current_statement->flag_in_debug = in_debugging;
292 emit_statement (CB_TREE (current_statement));
293 if (term) {
294 term_array[term]++;
295 }
296 }
297
298 static void
restore_backup_pos(cb_tree item)299 restore_backup_pos (cb_tree item)
300 {
301 item->source_file = backup_source_file;
302 item->source_line = backup_source_line;
303 }
304
305 static void
begin_statement_from_backup_pos(const char * name,const unsigned int term)306 begin_statement_from_backup_pos (const char *name, const unsigned int term)
307 {
308 current_paragraph->flag_statement = 1;
309 current_statement = cb_build_statement (name);
310 restore_backup_pos (CB_TREE (current_statement));
311 current_statement->flag_in_debug = in_debugging;
312 emit_statement (CB_TREE (current_statement));
313 if (term) {
314 term_array[term]++;
315 }
316 if (check_unreached) {
317 cb_warning_x (cb_warn_unreachable, CB_TREE (current_statement), _("unreachable statement '%s'"), name);
318 }
319 }
320
321 /* create a new statement with base attributes of current_statement
322 and set this as new current_statement */
323 static void
begin_implicit_statement(void)324 begin_implicit_statement (void)
325 {
326 struct cb_statement *new_statement;
327 new_statement = cb_build_statement (NULL);
328 new_statement->common = current_statement->common;
329 new_statement->name = current_statement->name;
330 new_statement->flag_in_debug = !!in_debugging;
331 new_statement->flag_implicit = 1;
332 current_statement->body = cb_list_add (current_statement->body,
333 CB_TREE (new_statement));
334 current_statement = new_statement;
335 }
336
337 # if 0 /* activate only for debugging purposes for attribs
338 FIXME: Replace by DEBUG_LOG function */
339 static
340 void print_bits (cob_flags_t num)
341 {
342 unsigned int size = sizeof (cob_flags_t);
343 unsigned int max_pow = 1 << (size * 8 - 1);
344 int i = 0;
345
346 for(; i < size * 8; ++i){
347 /* Print last bit and shift left. */
348 fprintf (stderr, "%u ", num & max_pow ? 1 : 0);
349 num = num << 1;
350 }
351 fprintf (stderr, "\n");
352 }
353 #endif
354
355 /* functions for storing current position and
356 assigning it to a cb_tree after its parsing is finished */
357 static COB_INLINE
backup_current_pos(void)358 void backup_current_pos (void)
359 {
360 backup_source_file = cb_source_file;
361 backup_source_line = cb_source_line;
362 }
363
364 #if 0 /* currently not used */
365 static COB_INLINE
366 void set_pos_from_backup (cb_tree x)
367 {
368 x->source_file = backup_source_file;
369 x->source_line = backup_source_line;
370 }
371 #endif
372
373 static void
emit_entry(const char * name,const int encode,cb_tree using_list,cb_tree convention)374 emit_entry (const char *name, const int encode, cb_tree using_list, cb_tree convention)
375 {
376 cb_tree l;
377 cb_tree check_list;
378 cb_tree label;
379 cb_tree x;
380 cb_tree entry_conv;
381 struct cb_field *f, *ret_f;
382 int param_num;
383 char buff[COB_MINI_BUFF];
384
385 snprintf (buff, (size_t)COB_MINI_MAX, "E$%s", name);
386 label = cb_build_label (cb_build_reference (buff), NULL);
387 if (encode) {
388 CB_LABEL (label)->name = cb_encode_program_id (name, 0, cb_fold_call);
389 CB_LABEL (label)->orig_name = name;
390 } else {
391 CB_LABEL (label)->name = name;
392 CB_LABEL (label)->orig_name = current_program->orig_program_id;
393 }
394 CB_LABEL (label)->flag_begin = 1;
395 CB_LABEL (label)->flag_entry = 1;
396 label->source_line = backup_source_line;
397 emit_statement (label);
398
399 if (current_program->flag_debugging) {
400 emit_statement (cb_build_debug (cb_debug_contents,
401 "START PROGRAM", NULL));
402 }
403
404 param_num = 1;
405 check_list = NULL;
406 for (l = using_list; l; l = CB_CHAIN (l)) {
407 x = CB_VALUE (l);
408 if (cb_try_ref (x) != cb_error_node) {
409 f = CB_FIELD (cb_ref (x));
410 if (!current_program->flag_chained) {
411 if (f->storage != CB_STORAGE_LINKAGE) {
412 cb_error_x (x, _("'%s' is not in LINKAGE SECTION"), f->name);
413 }
414 if (f->flag_item_based || f->flag_external) {
415 cb_error_x (x, _("'%s' cannot be BASED/EXTERNAL"), f->name);
416 }
417 f->flag_is_pdiv_parm = 1;
418 } else {
419 if (f->storage != CB_STORAGE_WORKING) {
420 cb_error_x (x, _("'%s' is not in WORKING-STORAGE SECTION"), f->name);
421 }
422 f->flag_chained = 1;
423 f->param_num = param_num;
424 param_num++;
425 }
426 if (f->level != 01 && f->level != 77) {
427 cb_error_x (x, _("'%s' not level 01 or 77"), f->name);
428 }
429 if (f->redefines) {
430 cb_error_x (x, _("'%s' REDEFINES field not allowed here"), f->name);
431 }
432 /* add a "receiving" entry for the USING parameter */
433 if (cb_listing_xref) {
434 cobc_xref_link (&f->xref, CB_REFERENCE (x)->common.source_line, 1);
435 }
436 if (CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
437 check_list = cb_list_add (check_list, x);
438 }
439 }
440 }
441
442 if (check_list != NULL) {
443 for (l = check_list; l; l = CB_CHAIN (l)) {
444 cb_tree l2 = CB_VALUE (l);
445 x = cb_ref (l2);
446 if (x != cb_error_node) {
447 for (l2 = check_list; l2 != l; l2 = CB_CHAIN (l2)) {
448 if (cb_ref (CB_VALUE (l2)) == x) {
449 cb_error_x (l,
450 _("duplicate USING BY REFERENCE item '%s'"),
451 cb_name (CB_VALUE (l)));
452 CB_VALUE (l) = cb_error_node;
453 break;
454 }
455 }
456 }
457 }
458 }
459
460 if (current_program->returning &&
461 cb_ref (current_program->returning) != cb_error_node) {
462 ret_f = CB_FIELD (cb_ref (current_program->returning));
463 if (ret_f->redefines) {
464 cb_error_x (current_program->returning,
465 _("'%s' REDEFINES field not allowed here"), ret_f->name);
466 }
467 } else {
468 ret_f = NULL;
469 }
470
471 /* Check returning item against using items when FUNCTION */
472 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION && ret_f) {
473 for (l = using_list; l; l = CB_CHAIN (l)) {
474 x = CB_VALUE (l);
475 if (CB_VALID_TREE (x) && cb_ref (x) != cb_error_node) {
476 f = CB_FIELD (cb_ref (x));
477 if (ret_f == f) {
478 cb_error_x (x, _("'%s' USING item duplicates RETURNING item"), f->name);
479 }
480 }
481 }
482 }
483
484 for (l = current_program->entry_list; l; l = CB_CHAIN (l)) {
485 struct cb_label *check = CB_LABEL (CB_PURPOSE (l));
486 if (strcmp (name, check->name) == 0) {
487 cb_error_x (CB_TREE (current_statement),
488 _("ENTRY '%s' duplicated"), name);
489 }
490 }
491
492 if (convention) {
493 entry_conv = convention;
494 } else {
495 entry_conv = current_program->entry_convention;
496 }
497
498 current_program->entry_list =
499 cb_list_append (current_program->entry_list,
500 CB_BUILD_PAIR (label, CB_BUILD_PAIR(entry_conv, using_list)));
501 }
502
503 static void
emit_entry_goto(const char * name)504 emit_entry_goto (const char *name)
505 {
506 cb_tree l;
507 cb_tree label;
508 char buff[COB_MINI_BUFF];
509
510 snprintf (buff, (size_t)COB_MINI_MAX, "E$%s", name);
511 label = cb_build_label (cb_build_reference (buff), NULL);
512 CB_LABEL (label)->name = name;
513 CB_LABEL (label)->orig_name = name;
514 CB_LABEL (label)->flag_begin = 1;
515 CB_LABEL (label)->flag_entry = 1;
516 CB_LABEL (label)->flag_entry_for_goto = 1;
517 label->source_line = backup_source_line;
518 emit_statement (label);
519
520 for (l = current_program->entry_list_goto; l; l = CB_CHAIN (l)) {
521 struct cb_label *real_label = CB_LABEL (CB_VALUE (l));
522 if (strcmp (name, real_label->name) == 0) {
523 cb_error_x (CB_TREE (current_statement),
524 _("ENTRY FOR GO TO '%s' duplicated"), name);
525 }
526 }
527
528 if (current_program->entry_list_goto) {
529 current_program->entry_list_goto =
530 cb_list_add (current_program->entry_list_goto, label);
531 } else {
532 current_program->entry_list_goto = CB_LIST_INIT (label);
533 }
534 }
535
536 static size_t
increment_depth(void)537 increment_depth (void)
538 {
539 if (++depth >= PROG_DEPTH) {
540 cb_error (_("maximum nested program depth exceeded (%d)"),
541 PROG_DEPTH);
542 return 1;
543 }
544 return 0;
545 }
546
547 static void
terminator_warning(cb_tree stmt,const unsigned int termid,const char * name)548 terminator_warning (cb_tree stmt, const unsigned int termid,
549 const char *name)
550 {
551 char terminator[32];
552
553 check_unreached = 0;
554 if (term_array[termid]) {
555 term_array[termid]--;
556 /* LCOV_EXCL_START */
557 } else {
558 cobc_err_msg ("call to '%s' without any open term for %s",
559 "terminator_warning", name);
560 COBC_ABORT ();
561 }
562 /* LCOV_EXCL_STOP */
563 snprintf (terminator, 32, "END-%s", name);
564 if (is_reserved_word (terminator)) {
565 cb_warning_x (cb_warn_terminator, CB_TREE (current_statement),
566 _("%s statement not terminated by %s"), name, terminator);
567 }
568
569 /* Free tree associated with terminator */
570 if (stmt) {
571 cobc_parse_free (stmt);
572 }
573 }
574
575 static void
terminator_error(cb_tree stmt,const unsigned int termid,const char * name)576 terminator_error (cb_tree stmt, const unsigned int termid, const char *name)
577 {
578 char terminator[32];
579
580 check_unreached = 0;
581 if (term_array[termid]) {
582 term_array[termid]--;
583 /* LCOV_EXCL_START */
584 } else {
585 cobc_err_msg ("call to '%s' without any open term for %s",
586 "terminator_error", name);
587 COBC_ABORT ();
588 }
589 /* LCOV_EXCL_STOP */
590 snprintf (terminator, 32, "END-%s", name);
591 if (is_reserved_word (terminator)) {
592 cb_error_x (CB_TREE (current_statement),
593 _("%s statement not terminated by %s"), name, terminator);
594 } else {
595 cb_error_x (CB_TREE (current_statement),
596 _("%s statement not terminated"), name);
597 }
598
599 /* Free tree associated with terminator */
600 if (stmt) {
601 cobc_parse_free (stmt);
602 }
603 }
604
605 static void
terminator_clear(cb_tree stmt,const unsigned int termid)606 terminator_clear (cb_tree stmt, const unsigned int termid)
607 {
608 struct cb_perform *p;
609 check_unreached = 0;
610 if (term_array[termid]) {
611 term_array[termid]--;
612 /* LCOV_EXCL_START */
613 } else {
614 cobc_err_msg ("call to '%s' without any open term for %s",
615 "terminator_warning", current_statement->name);
616 COBC_ABORT ();
617 }
618 /* LCOV_EXCL_STOP */
619 if (termid == TERM_PERFORM
620 && perform_stack) {
621 p = CB_PERFORM (CB_VALUE (perform_stack));
622 if (p->perform_type == CB_PERFORM_UNTIL) {
623 cb_terminate_cond ();
624 }
625 }
626 /* Free tree associated with terminator */
627 if (stmt) {
628 cobc_parse_free (stmt);
629 }
630 }
631
632 static int
literal_value(cb_tree x)633 literal_value (cb_tree x)
634 {
635 if (x == cb_space) {
636 return ' ';
637 } else if (x == cb_zero) {
638 return '0';
639 } else if (x == cb_quote) {
640 return cb_flag_apostrophe ? '\'' : '"';
641 } else if (x == cb_null) {
642 return 0;
643 } else if (x == cb_low) {
644 return 0;
645 } else if (x == cb_high) {
646 return 255;
647 } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
648 return cb_get_int (x);
649 } else {
650 return CB_LITERAL (x)->data[0];
651 }
652 }
653
654 static void
setup_use_file(struct cb_file * fileptr)655 setup_use_file (struct cb_file *fileptr)
656 {
657 struct cb_file *newptr;
658
659 if (fileptr->organization == COB_ORG_SORT) {
660 cb_error (_("USE statement invalid for SORT file"));
661 }
662 if (fileptr->flag_global) {
663 newptr = cobc_parse_malloc (sizeof(struct cb_file));
664 *newptr = *fileptr;
665 newptr->handler = current_section;
666 newptr->handler_prog = current_program;
667 if (!use_global_ind) {
668 current_program->local_file_list =
669 cb_list_add (current_program->local_file_list,
670 CB_TREE (newptr));
671 } else {
672 current_program->global_file_list =
673 cb_list_add (current_program->global_file_list,
674 CB_TREE (newptr));
675 }
676 } else {
677 fileptr->handler = current_section;
678 }
679 }
680
681 /* note: same message in field.c */
682 static int
emit_duplicate_clause_message(const char * clause)683 emit_duplicate_clause_message (const char *clause)
684 {
685 /* FIXME: replace by a new warning level that is set
686 to warn/error depending on cb_relaxed_syntax_checks */
687 if (cb_relaxed_syntax_checks) {
688 cb_warning (COBC_WARN_FILLER, _("duplicate %s clause"), clause);
689 return 0;
690 }
691 cb_error (_("duplicate %s clause"), clause);
692 return 1;
693 }
694
695 static int
check_repeated(const char * clause,const cob_flags_t bitval,cob_flags_t * already_seen)696 check_repeated (const char *clause, const cob_flags_t bitval,
697 cob_flags_t *already_seen)
698 {
699 if (*already_seen & bitval) {
700 return emit_duplicate_clause_message (clause);
701 }
702 *already_seen |= bitval;
703 return 0;
704 }
705
706 static void
emit_conflicting_clause_message(const char * clause,const char * conflicting)707 emit_conflicting_clause_message (const char *clause, const char *conflicting)
708 {
709 if (cb_relaxed_syntax_checks) {
710 cb_warning (COBC_WARN_FILLER, _("cannot specify both %s and %s; %s is ignored"),
711 clause, conflicting, clause);
712 } else {
713 cb_error (_("cannot specify both %s and %s"),
714 clause, conflicting);
715 }
716
717 }
718
719
720 static void
error_if_no_page_lines_limit(const char * phrase)721 error_if_no_page_lines_limit (const char *phrase)
722 {
723 if (!current_report->lines && !current_report->t_lines) {
724 cb_error (_("Cannot specify %s without number of lines on page"),
725 phrase);
726 }
727 }
728
729 static void
setup_occurs(void)730 setup_occurs (void)
731 {
732 check_repeated ("OCCURS", SYN_CLAUSE_7, &check_pic_duplicate);
733 if (current_field->indexes == COB_MAX_SUBSCRIPTS) {
734 cb_error (_("maximum OCCURS depth exceeded (%d)"),
735 COB_MAX_SUBSCRIPTS);
736 } else {
737 current_field->indexes++;
738 }
739
740 if (current_field->flag_unbounded) {
741 if (current_field->storage != CB_STORAGE_LINKAGE) {
742 cb_error_x (CB_TREE(current_field), _("'%s' is not in LINKAGE SECTION"),
743 cb_name (CB_TREE(current_field)));
744 }
745 }
746
747 if (current_field->flag_item_based) {
748 cb_error (_("%s and %s are mutually exclusive"), "BASED", "OCCURS");
749 } else if (current_field->flag_external) {
750 cb_error (_("%s and %s are mutually exclusive"), "EXTERNAL", "OCCURS");
751 }
752 current_field->flag_occurs = 1;
753 }
754
755 static void
setup_occurs_min_max(cb_tree occurs_min,cb_tree occurs_max)756 setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max)
757 {
758 if (occurs_max) {
759 current_field->occurs_min = cb_get_int (occurs_min);
760 if (occurs_max != cb_int0) {
761 current_field->occurs_max = cb_get_int (occurs_max);
762 if (!current_field->depending) {
763 if (cb_relaxed_syntax_checks) {
764 cb_warning (COBC_WARN_FILLER, _("TO phrase without DEPENDING phrase"));
765 cb_warning (COBC_WARN_FILLER, _("maximum number of occurrences assumed to be exact number"));
766 current_field->occurs_min = 1; /* CHECKME: why using 1 ? */
767 } else {
768 cb_error (_("TO phrase without DEPENDING phrase"));
769 }
770 }
771 if (current_field->occurs_max <= current_field->occurs_min) {
772 cb_error (_("OCCURS TO must be greater than OCCURS FROM"));
773 }
774 } else {
775 current_field->occurs_max = 0;
776 }
777 } else {
778 current_field->occurs_min = 1; /* CHECKME: why using 1 ? */
779 current_field->occurs_max = cb_get_int (occurs_min);
780 if (current_field->depending) {
781 cb_verify (cb_odo_without_to, _("OCCURS DEPENDING ON without TO phrase"));
782 }
783 }
784 }
785
786 static void
check_relaxed_syntax(const cob_flags_t lev)787 check_relaxed_syntax (const cob_flags_t lev)
788 {
789 const char *s;
790
791 switch (lev) {
792 case COBC_HD_ENVIRONMENT_DIVISION:
793 s = "ENVIRONMENT DIVISION";
794 break;
795 case COBC_HD_CONFIGURATION_SECTION:
796 s = "CONFIGURATION SECTION";
797 break;
798 case COBC_HD_SPECIAL_NAMES:
799 s = "SPECIAL-NAMES";
800 break;
801 case COBC_HD_INPUT_OUTPUT_SECTION:
802 s = "INPUT-OUTPUT SECTION";
803 break;
804 case COBC_HD_FILE_CONTROL:
805 s = "FILE-CONTROL";
806 break;
807 case COBC_HD_I_O_CONTROL:
808 s = "I-O-CONTROL";
809 break;
810 case COBC_HD_DATA_DIVISION:
811 s = "DATA DIVISION";
812 break;
813 case COBC_HD_FILE_SECTION:
814 s = "FILE SECTION";
815 break;
816 case COBC_HD_WORKING_STORAGE_SECTION:
817 s = "WORKING-STORAGE SECTION";
818 break;
819 case COBC_HD_LOCAL_STORAGE_SECTION:
820 s = "LOCAL-STORAGE SECTION";
821 break;
822 case COBC_HD_LINKAGE_SECTION:
823 s = "LINKAGE SECTION";
824 break;
825 case COBC_HD_COMMUNICATION_SECTION:
826 s = "COMMUNICATION SECTION";
827 break;
828 case COBC_HD_REPORT_SECTION:
829 s = "REPORT SECTION";
830 break;
831 case COBC_HD_SCREEN_SECTION:
832 s = "SCREEN SECTION";
833 break;
834 case COBC_HD_PROCEDURE_DIVISION:
835 s = "PROCEDURE DIVISION";
836 break;
837 case COBC_HD_PROGRAM_ID:
838 s = "PROGRAM-ID";
839 break;
840 /* LCOV_EXCL_START */
841 default:
842 s = _("unknown");
843 break;
844 /* LCOV_EXCL_STOP */
845 }
846 if (cb_relaxed_syntax_checks) {
847 cb_warning (COBC_WARN_FILLER, _("%s header missing - assumed"), s);
848 } else {
849 cb_error (_("%s header missing"), s);
850 }
851 }
852
853 static void
program_init_without_program_id(void)854 program_init_without_program_id (void)
855 {
856 cb_tree l;
857
858 current_section = NULL;
859 current_paragraph = NULL;
860 l = cb_build_alphanumeric_literal (demangle_name,
861 strlen (demangle_name));
862 current_program->program_name = (char *)CB_LITERAL (l)->data;
863 current_program->program_id
864 = cb_build_program_id (current_program->program_name, 0);
865 current_program->prog_type = COB_MODULE_TYPE_PROGRAM;
866 if (!main_flag_set) {
867 main_flag_set = 1;
868 current_program->flag_main = cobc_flag_main;
869 }
870 check_relaxed_syntax (COBC_HD_PROGRAM_ID);
871 }
872
873 /* check if headers are present - return 0 if fine, 1 if missing
874 Lev1 must always be present and is checked
875 Lev2/3/4, if non-zero (forced) may be present
876 */
877 static int
check_headers_present(const cob_flags_t lev1,const cob_flags_t lev2,const cob_flags_t lev3,const cob_flags_t lev4)878 check_headers_present (const cob_flags_t lev1, const cob_flags_t lev2,
879 const cob_flags_t lev3, const cob_flags_t lev4)
880 {
881 int ret = 0;
882 if (!(header_check & lev1)) {
883 header_check |= lev1;
884 check_relaxed_syntax (lev1);
885 ret = 1;
886 }
887 if (lev2) {
888 if (!(header_check & lev2)) {
889 header_check |= lev2;
890 check_relaxed_syntax (lev2);
891 ret = 1;
892 }
893 }
894 if (lev3) {
895 if (!(header_check & lev3)) {
896 header_check |= lev3;
897 check_relaxed_syntax (lev3);
898 ret = 1;
899 }
900 }
901 if (lev4) {
902 if (!(header_check & lev4)) {
903 header_check |= lev4;
904 check_relaxed_syntax (lev4);
905 ret = 1;
906 }
907 }
908 return ret;
909 }
910
911 /*
912 TO-DO: Refactor header checks - have several header_checks: division_header,
913 section_header, paragraph_header, sentence_type
914 */
915 static void
set_conf_section_part(const cob_flags_t part)916 set_conf_section_part (const cob_flags_t part)
917 {
918 header_check &= ~COBC_HD_SOURCE_COMPUTER;
919 header_check &= ~COBC_HD_OBJECT_COMPUTER;
920 header_check &= ~COBC_HD_SPECIAL_NAMES;
921 header_check &= ~COBC_HD_REPOSITORY;
922 header_check |= part;
923 }
924
925 static const char *
get_conf_section_part_name(const cob_flags_t part)926 get_conf_section_part_name (const cob_flags_t part)
927 {
928 if (part == COBC_HD_SOURCE_COMPUTER) {
929 return "SOURCE-COMPUTER";
930 } else if (part == COBC_HD_OBJECT_COMPUTER) {
931 return "OBJECT-COMPUTER";
932 } else if (part == COBC_HD_SPECIAL_NAMES) {
933 return "SPECIAL-NAMES";
934 } else if (part == COBC_HD_REPOSITORY) {
935 return "REPOSITORY";
936 /* LCOV_EXCL_START */
937 } else {
938 /* This should never happen (and therefore doesn't get a translation) */
939 cb_error ("unexpected configuration section part " CB_FMT_LLU, part);
940 COBC_ABORT ();
941 /* LCOV_EXCL_STOP */
942 }
943 }
944
945 static int
get_conf_section_part_order(const cob_flags_t part)946 get_conf_section_part_order (const cob_flags_t part)
947 {
948 if (part == COBC_HD_SOURCE_COMPUTER) {
949 return 1;
950 } else if (part == COBC_HD_OBJECT_COMPUTER) {
951 return 2;
952 } else if (part == COBC_HD_SPECIAL_NAMES) {
953 return 3;
954 } else if (part == COBC_HD_REPOSITORY) {
955 return 4;
956 /* LCOV_EXCL_START */
957 } else {
958 /* This should never happen (and therefore doesn't get a translation) */
959 cb_error ("unexpected configuration section part " CB_FMT_LLU, part);
960 COBC_ABORT ();
961 /* LCOV_EXCL_STOP */
962 }
963 }
964
965 static void
check_conf_section_order(const cob_flags_t part)966 check_conf_section_order (const cob_flags_t part)
967 {
968 const cob_flags_t prev_part
969 = header_check & (COBC_HD_SOURCE_COMPUTER
970 | COBC_HD_OBJECT_COMPUTER
971 | COBC_HD_SPECIAL_NAMES
972 | COBC_HD_REPOSITORY);
973 #define MESSAGE_LEN 100
974 char message[MESSAGE_LEN] = { '\0' };
975
976 if (prev_part == 0) {
977 return;
978 }
979
980 if (prev_part == part) {
981 cb_error (_("duplicate %s"), get_conf_section_part_name (part));
982 } else if (get_conf_section_part_order (part) < get_conf_section_part_order (prev_part)) {
983 snprintf (message, MESSAGE_LEN, _("%s incorrectly after %s"),
984 get_conf_section_part_name (part),
985 get_conf_section_part_name (prev_part));
986 cb_verify (cb_incorrect_conf_sec_order, message);
987 }
988 }
989
990 #undef MESSAGE_LEN
991
992 static void
build_words_for_nested_programs(void)993 build_words_for_nested_programs (void)
994 {
995 cb_tree x;
996 cb_tree y;
997
998 /* Inherit special name mnemonics from parent */
999 for (x = current_program->mnemonic_spec_list; x; x = CB_CHAIN (x)) {
1000 y = cb_build_reference (cb_name(CB_PURPOSE(x)));
1001 if (CB_SYSTEM_NAME_P (CB_VALUE(x))) {
1002 cb_define (y, CB_VALUE(x));
1003 } else {
1004 cb_build_constant (y, CB_VALUE(x));
1005 }
1006 }
1007
1008 /* Inherit class names from parent */
1009 for (x = current_program->class_name_list; x; x = CB_CHAIN(x)) {
1010 y = cb_build_reference (cb_name(CB_VALUE(x)));
1011 cb_define (y, CB_VALUE(x));
1012 }
1013 }
1014
1015 static void
clear_initial_values(void)1016 clear_initial_values (void)
1017 {
1018 perform_stack = NULL;
1019 current_statement = NULL;
1020 qualifier = NULL;
1021 in_declaratives = 0;
1022 in_debugging = 0;
1023 use_global_ind = 0;
1024 check_duplicate = 0;
1025 check_pic_duplicate = 0;
1026 skip_statements = 0;
1027 start_debug = 0;
1028 save_debug = 0;
1029 needs_field_debug = 0;
1030 needs_debug_item = 0;
1031 env_div_seen = 0;
1032 header_check = 0;
1033 next_label_id = 0;
1034 current_linage = 0;
1035 set_attr_val_on = 0;
1036 set_attr_val_off = 0;
1037 report_count = 0;
1038 current_storage = CB_STORAGE_WORKING;
1039 eval_level = 0;
1040 eval_inc = 0;
1041 eval_inc2 = 0;
1042 inspect_keyword = 0;
1043 check_unreached = 0;
1044 cobc_in_id = 0;
1045 cobc_in_procedure = 0;
1046 cobc_in_repository = 0;
1047 cobc_force_literal = 0;
1048 cobc_in_xml_generate_body = 0;
1049 cobc_in_json_generate_body = 0;
1050 non_const_word = 0;
1051 suppress_data_exceptions = 0;
1052 same_area = 1;
1053 memset ((void *)eval_check, 0, sizeof(eval_check));
1054 memset ((void *)term_array, 0, sizeof(term_array));
1055 linage_file = NULL;
1056 current_file = NULL;
1057 current_cd = NULL;
1058 current_report = NULL;
1059 report_instance = NULL;
1060 next_label_list = NULL;
1061 default_rounded_mode = cb_int (COB_STORE_ROUND);
1062 }
1063
1064 /*
1065 We must check for redefinitions of program-names and external program names
1066 outside of the usual reference/word_list methods as it may have to be done in
1067 a case-sensitive way.
1068 */
1069 static void
begin_scope_of_program_name(struct cb_program * program)1070 begin_scope_of_program_name (struct cb_program *program)
1071 {
1072 const char *prog_name = program->program_name;
1073 const char *prog_id = program->orig_program_id;
1074 const char *elt_name;
1075 const char *elt_id;
1076 cb_tree l;
1077
1078 /* Error if a program with the same name has been defined. */
1079 for (l = defined_prog_list; l; l = CB_CHAIN (l)) {
1080 elt_name = ((struct cb_program *) CB_VALUE (l))->program_name;
1081 elt_id = ((struct cb_program *) CB_VALUE (l))->orig_program_id;
1082 if (cb_fold_call && strcasecmp (prog_name, elt_name) == 0) {
1083 cb_error_x ((cb_tree) program,
1084 _("redefinition of program name '%s'"),
1085 elt_name);
1086 } else if (strcmp (prog_id, elt_id) == 0) {
1087 cb_error_x ((cb_tree) program,
1088 _("redefinition of program ID '%s'"),
1089 elt_id);
1090 return;
1091 }
1092 }
1093
1094 /* Otherwise, add the program to the list. */
1095 defined_prog_list = cb_list_add (defined_prog_list,
1096 (cb_tree) program);
1097 }
1098
1099 static void
remove_program_name(struct cb_list * l,struct cb_list * prev)1100 remove_program_name (struct cb_list *l, struct cb_list *prev)
1101 {
1102 if (prev == NULL) {
1103 defined_prog_list = l->chain;
1104 } else {
1105 prev->chain = l->chain;
1106 }
1107 cobc_parse_free (l);
1108 }
1109
1110 /* Remove the program from defined_prog_list, if necessary. */
1111 static void
end_scope_of_program_name(struct cb_program * program,const unsigned char type)1112 end_scope_of_program_name (struct cb_program *program, const unsigned char type)
1113 {
1114 struct cb_list *prev = NULL;
1115 struct cb_list *l = (struct cb_list *) defined_prog_list;
1116
1117 /* create empty entry if the program has no PROCEDURE DIVISION, error for UDF */
1118 if (!program->entry_list) {
1119 if (type == COB_MODULE_TYPE_FUNCTION) {
1120 cb_error (_("FUNCTION '%s' has no PROCEDURE DIVISION"), program->program_name);
1121 } else {
1122 emit_entry (program->program_id, 0, NULL, NULL);
1123 }
1124 }
1125 program->last_source_line = backup_source_line;
1126
1127 if (program->nested_level == 0) {
1128 return;
1129 }
1130
1131 /* Remove any subprograms */
1132 l = CB_LIST (defined_prog_list);
1133 while (l) {
1134 if (CB_PROGRAM (l->value)->nested_level > program->nested_level) {
1135 remove_program_name (l, prev);
1136 } else {
1137 prev = l;
1138 }
1139 if (prev && prev->chain != NULL) {
1140 l = CB_LIST (prev->chain);
1141 } else {
1142 l = NULL;
1143 }
1144 }
1145
1146 /* Remove the specified program, if it is not COMMON */
1147 if (!program->flag_common) {
1148 l = (struct cb_list *) defined_prog_list;
1149 while (l) {
1150 /* The nested_level check is for the pathological case
1151 where two nested programs have the same name */
1152 if (0 == strcmp (program->orig_program_id,
1153 CB_PROGRAM (l->value)->orig_program_id)
1154 && program->nested_level == CB_PROGRAM (l->value)->nested_level) {
1155 remove_program_name (l, prev);
1156 if (prev && prev->chain != NULL) {
1157 l = CB_LIST (prev->chain);
1158 } else {
1159 l = NULL;
1160 }
1161 break;
1162 } else {
1163 prev = l;
1164 if (l->chain != NULL) {
1165 l = CB_LIST (l->chain);
1166 } else {
1167 l = NULL;
1168 }
1169 }
1170 }
1171 }
1172 }
1173
1174 static void
setup_program_start(void)1175 setup_program_start (void)
1176 {
1177 if (setup_from_identification) {
1178 setup_from_identification = 0;
1179 return;
1180 }
1181 current_section = NULL;
1182 current_paragraph = NULL;
1183
1184 if (depth != 0 && first_nested_program) {
1185 check_headers_present (COBC_HD_PROCEDURE_DIVISION, 0, 0, 0);
1186 }
1187 first_nested_program = 1;
1188 }
1189
1190 static int
setup_program(cb_tree id,cb_tree as_literal,const unsigned char type)1191 setup_program (cb_tree id, cb_tree as_literal, const unsigned char type)
1192 {
1193 const char *external_name = NULL;
1194
1195 setup_program_start ();
1196
1197 /* finish last program/function */
1198 if (!first_prog) {
1199 if (!current_program->flag_validated) {
1200 current_program->flag_validated = 1;
1201 cb_validate_program_body (current_program);
1202 }
1203
1204 clear_initial_values ();
1205 current_program = cb_build_program (current_program, depth);
1206 if (depth) {
1207 build_words_for_nested_programs();
1208 }
1209 cb_set_intr_when_compiled ();
1210 cb_build_registers ();
1211 cb_add_external_defined_registers ();
1212 } else {
1213 first_prog = 0;
1214 }
1215
1216 /* set internal name */
1217 if (CB_LITERAL_P (id)) {
1218 current_program->program_name = (char *)CB_LITERAL (id)->data;
1219 } else {
1220 current_program->program_name = CB_NAME (id);
1221 }
1222 stack_progid[depth] = current_program->program_name;
1223 current_program->prog_type = type;
1224
1225 if (depth != 0 && type == COB_MODULE_TYPE_FUNCTION) {
1226 cb_error (_("functions may not be defined within a program/function"));
1227 }
1228
1229 if (increment_depth ()) {
1230 return 1;
1231 }
1232
1233 /* set external name if specified */
1234 if (as_literal) {
1235 external_name = (const char *)CB_LITERAL (as_literal)->data;
1236 } else {
1237 external_name = current_program->program_name;
1238 }
1239
1240 /* build encoded external PROGRAM-ID */
1241 current_program->program_id
1242 = cb_build_program_id (external_name, type == COB_MODULE_TYPE_FUNCTION);
1243
1244 if (type == COB_MODULE_TYPE_PROGRAM) {
1245 if (!main_flag_set) {
1246 main_flag_set = 1;
1247 current_program->flag_main = !!cobc_flag_main;
1248 }
1249 } else { /* COB_MODULE_TYPE_FUNCTION */
1250 current_program->flag_recursive = 1;
1251 }
1252
1253 if (CB_REFERENCE_P (id)) {
1254 cb_define (id, CB_TREE (current_program));
1255 }
1256
1257 begin_scope_of_program_name (current_program);
1258
1259 return 0;
1260 }
1261
1262 static void
decrement_depth(const char * name,const unsigned char type)1263 decrement_depth (const char *name, const unsigned char type)
1264 {
1265 int d;
1266
1267 if (depth) {
1268 depth--;
1269 }
1270
1271 if (!strcmp (stack_progid[depth], name)) {
1272 return;
1273 }
1274
1275 if (type == COB_MODULE_TYPE_FUNCTION) {
1276 cb_error (_("END FUNCTION '%s' is different from FUNCTION-ID '%s'"),
1277 name, stack_progid[depth]);
1278 return;
1279 }
1280
1281 /* Set depth to that of whatever program we just ended, if it exists. */
1282 for (d = depth; d >= 0; --d) {
1283 if (!strcmp (stack_progid[d], name)) {
1284 depth = d;
1285 return;
1286 }
1287 }
1288
1289 if (depth != d) {
1290 cb_error (_("END PROGRAM '%s' is different from PROGRAM-ID '%s'"),
1291 name, stack_progid[depth]);
1292 }
1293 }
1294
1295 static void
clean_up_program(cb_tree name,const unsigned char type)1296 clean_up_program (cb_tree name, const unsigned char type)
1297 {
1298 char *s;
1299
1300 end_scope_of_program_name (current_program, type);
1301
1302 if (name) {
1303 if (CB_LITERAL_P (name)) {
1304 s = (char *)(CB_LITERAL (name)->data);
1305 } else {
1306 s = (char *)(CB_NAME (name));
1307 }
1308
1309 decrement_depth (s, type);
1310 }
1311
1312 current_section = NULL;
1313 current_paragraph = NULL;
1314 if (!current_program->flag_validated) {
1315 current_program->flag_validated = 1;
1316 cb_validate_program_body (current_program);
1317 }
1318 }
1319
1320 static const char *
get_literal_or_word_name(const cb_tree x)1321 get_literal_or_word_name (const cb_tree x)
1322 {
1323 if (CB_LITERAL_P (x)) {
1324 return (const char *) CB_LITERAL (x)->data;
1325 } else { /* CB_REFERENCE_P (x) */
1326 return (const char *) CB_NAME (x);
1327 }
1328 }
1329
1330 /* verify and set currency symbol used in picture (compile time) and - if no currency
1331 string is explicitly set (which is currently not implemented) - as currency string
1332 (run time for display and [de-]editing)*/
1333 static void
set_currency_picture_symbol(const cb_tree x)1334 set_currency_picture_symbol (const cb_tree x)
1335 {
1336 unsigned char *s = CB_LITERAL (x)->data;
1337
1338 if (CB_LITERAL (x)->size != 1) {
1339 cb_error_x (x, _("currency symbol must be one character long"));
1340 return;
1341 }
1342 switch (*s) {
1343 case '0':
1344 case '1':
1345 case '2':
1346 case '3':
1347 case '4':
1348 case '5':
1349 case '6':
1350 case '7':
1351 case '8':
1352 case '9':
1353 case 'A':
1354 case 'B':
1355 case 'C':
1356 case 'D':
1357 case 'E':
1358 case 'N':
1359 case 'P':
1360 case 'R':
1361 case 'S':
1362 case 'V':
1363 case 'X':
1364 case 'Z':
1365 case 'a':
1366 case 'b':
1367 case 'c':
1368 case 'd':
1369 case 'e':
1370 case 'n':
1371 case 'p':
1372 case 'r':
1373 case 's':
1374 case 'v':
1375 case 'x':
1376 case 'z':
1377 case '+':
1378 case '-':
1379 case ',':
1380 case '.':
1381 case '*':
1382 case '/':
1383 case ';':
1384 case '(':
1385 case ')':
1386 case '=':
1387 case '\'':
1388 case '"':
1389 case ' ':
1390 #if 0 /* note: MicroFocus also dissalows L (VAX) and G (OSVS) */
1391 case 'L':
1392 case 'G':
1393 case 'l':
1394 case 'g':
1395 #endif
1396 cb_error_x (x, _("invalid character '%c' in currency symbol"), s[0]);
1397 return;
1398 default:
1399 break;
1400 }
1401 current_program->currency_symbol = s[0];
1402 }
1403
1404 /* Return 1 if the prototype name is the same as the current function's. */
1405 static int
check_prototype_redefines_current_element(const cb_tree prototype_name)1406 check_prototype_redefines_current_element (const cb_tree prototype_name)
1407 {
1408 const char *name = get_literal_or_word_name (prototype_name);
1409
1410 if (strcasecmp (name, current_program->program_name) == 0) {
1411 cb_warning_x (COBC_WARN_FILLER, prototype_name,
1412 _("prototype has same name as current function and will be ignored"));
1413 return 1;
1414 }
1415
1416 return 0;
1417 }
1418
1419 /* Returns 1 if the prototype has been duplicated. */
1420 static int
check_for_duplicate_prototype(const cb_tree prototype_name,const cb_tree prototype)1421 check_for_duplicate_prototype (const cb_tree prototype_name,
1422 const cb_tree prototype)
1423 {
1424 cb_tree dup;
1425
1426 if (CB_WORD_COUNT (prototype_name) > 0) {
1427 /* Make sure the duplicate is a prototype */
1428 dup = cb_ref (prototype_name);
1429 if (!CB_PROTOTYPE_P (dup)) {
1430 redefinition_error (prototype_name);
1431 return 1;
1432 }
1433
1434 /* Check the duplicate prototypes match */
1435 if (strcmp (CB_PROTOTYPE (prototype)->ext_name,
1436 CB_PROTOTYPE (dup)->ext_name)
1437 || CB_PROTOTYPE (prototype)->type != CB_PROTOTYPE (dup)->type) {
1438 cb_error_x (prototype_name,
1439 _("duplicate REPOSITORY entries for '%s' do not match"),
1440 get_literal_or_word_name (prototype_name));
1441 } else {
1442 cb_warning_x (COBC_WARN_FILLER, prototype_name,
1443 _("duplicate REPOSITORY entry for '%s'"),
1444 get_literal_or_word_name (prototype_name));
1445 }
1446 return 1;
1447 }
1448
1449 return 0;
1450 }
1451
1452 static void
setup_prototype(cb_tree prototype_name,cb_tree ext_name,const int type,const int is_current_element)1453 setup_prototype (cb_tree prototype_name, cb_tree ext_name,
1454 const int type, const int is_current_element)
1455 {
1456 cb_tree prototype;
1457 int name_redefinition_allowed;
1458
1459 if (!is_current_element
1460 && check_prototype_redefines_current_element (prototype_name)) {
1461 return;
1462 }
1463
1464 prototype = cb_build_prototype (prototype_name, ext_name, type);
1465
1466 if (!is_current_element
1467 && check_for_duplicate_prototype (prototype_name, prototype)) {
1468 return;
1469 }
1470
1471 name_redefinition_allowed = type == COB_MODULE_TYPE_PROGRAM
1472 && is_current_element && cb_program_name_redefinition;
1473 if (!name_redefinition_allowed) {
1474 if (CB_LITERAL_P (prototype_name)) {
1475 cb_define (cb_build_reference ((const char *)CB_LITERAL (prototype_name)->data), prototype);
1476 } else {
1477 cb_define (prototype_name, prototype);
1478 }
1479
1480 if (type == COB_MODULE_TYPE_PROGRAM) {
1481 current_program->program_spec_list =
1482 cb_list_add (current_program->program_spec_list, prototype);
1483 } else { /* COB_MODULE_TYPE_FUNCTION */
1484 current_program->user_spec_list =
1485 cb_list_add (current_program->user_spec_list, prototype);
1486 }
1487 }
1488 }
1489
1490 static void
error_if_record_delimiter_incompatible(const int organization,const char * organization_name)1491 error_if_record_delimiter_incompatible (const int organization,
1492 const char *organization_name)
1493 {
1494 int is_compatible;
1495
1496 if (!current_file->flag_delimiter) {
1497 return;
1498 }
1499
1500 if (organization == COB_ORG_LINE_SEQUENTIAL) {
1501 is_compatible = current_file->organization == COB_ORG_SEQUENTIAL
1502 || current_file->organization == COB_ORG_LINE_SEQUENTIAL;
1503 } else {
1504 is_compatible = current_file->organization == organization;
1505 }
1506
1507 if (!is_compatible) {
1508 cb_error (_("ORGANIZATION %s is incompatible with RECORD DELIMITER"),
1509 organization_name);
1510 }
1511 }
1512
1513 static int
set_current_field(cb_tree level,cb_tree name)1514 set_current_field (cb_tree level, cb_tree name)
1515 {
1516 cb_tree x = cb_build_field_tree (level, name, current_field,
1517 current_storage, current_file, 0);
1518 /* Free tree associated with level number */
1519 cobc_parse_free (level);
1520
1521 if (CB_INVALID_TREE (x)) {
1522 return 1;
1523 } else {
1524 current_field = CB_FIELD (x);
1525 check_pic_duplicate = 0;
1526 if (current_field->level == 1 || current_field->level == 77) {
1527 within_typedef_definition = 0;
1528 }
1529 }
1530
1531 return 0;
1532 }
1533
1534 static void
setup_external_definition(cb_tree x,const int type)1535 setup_external_definition (cb_tree x, const int type)
1536 {
1537 /* note: syntax checks for conflicting clauses
1538 are done in inherit_external_definition */
1539
1540 if (x != cb_error_node) {
1541 struct cb_field *f = CB_FIELD (cb_ref (x));
1542
1543 /* additional checks if the definition isn't provided by type */
1544 if (type != 1 /* called with SAME AS / LIKE data-name */ ) {
1545 if (f->level == 88) {
1546 cb_error (_("condition-name not allowed here: '%s'"), cb_name (x));
1547 x = cb_error_node;
1548 }
1549 /* note: the following are not explicit specified but implied with
1550 LIKE as ILE-COBOL does not have those sections */
1551 if (f->storage == CB_STORAGE_SCREEN) {
1552 cb_error (_("SCREEN item cannot be used here"));
1553 x = cb_error_node;
1554 } else if (f->storage == CB_STORAGE_REPORT) {
1555 cb_error (_("REPORT item cannot be used here"));
1556 x = cb_error_node;
1557 }
1558 if (type == 0) {
1559 /* rules that apply only to SAME AS */
1560 if (f->flag_is_typedef) {
1561 cb_error (_("TYPEDEF item cannot be used here"));
1562 x = cb_error_node;
1563 }
1564 }
1565 }
1566
1567 if (current_field->level == 77) {
1568 if (type != 2 /* called with LIKE */
1569 && f->children) {
1570 cb_error (_("elementary item expected"));
1571 x = cb_error_node;
1572 }
1573 } else {
1574 struct cb_field *p;
1575 for (p = current_field; p; p = p->parent) {
1576 if (p == f) {
1577 cb_error (_("item may not reference itself"));
1578 x = cb_error_node;
1579 break;
1580 }
1581 }
1582 for (p = f->parent; p; p = p->parent) {
1583 if (p->usage != CB_USAGE_DISPLAY) {
1584 cb_error (_("item may not be subordinate to any item with USAGE clause"));
1585 } else if (p->flag_sign_clause) {
1586 cb_error (_("item may not be subordinate to any item with SIGN clause"));
1587 } else {
1588 continue;
1589 }
1590 x = cb_error_node;
1591 break;
1592 }
1593 }
1594 }
1595
1596 if (x == cb_error_node) {
1597 current_field->flag_is_verified = 1;
1598 current_field->flag_invalid = 1;
1599 current_field->external_definition = cb_error_node;
1600 } else {
1601 current_field->external_definition = cb_ref (x);
1602 }
1603 }
1604
1605 static void
setup_external_definition_type(cb_tree x)1606 setup_external_definition_type (cb_tree x)
1607 {
1608 if (!check_repeated ("TYPE TO", SYN_CLAUSE_31, &check_pic_duplicate)) {
1609 if (current_field->external_definition) {
1610 emit_conflicting_clause_message ("SAME AS", "TYPE TO");
1611 }
1612 setup_external_definition (x, 1);
1613 }
1614 }
1615
1616 /* verifies that no conflicting clauses are used and
1617 inherits the definition of the original field specified
1618 by SAME AS or by type_name */
1619 static void
inherit_external_definition(cb_tree lvl)1620 inherit_external_definition (cb_tree lvl)
1621 {
1622 /* note: REDEFINES (clause 1) is allowed with RM/COBOL but not COBOL 2002+ */
1623 static const cob_flags_t allowed_clauses =
1624 SYN_CLAUSE_1 | SYN_CLAUSE_2 | SYN_CLAUSE_3 | SYN_CLAUSE_7 | SYN_CLAUSE_12;
1625 cob_flags_t tested = check_pic_duplicate & ~(allowed_clauses);
1626 if (tested != SYN_CLAUSE_30 && tested != SYN_CLAUSE_31
1627 && tested != 0 /* USAGE as TYPE TO */) {
1628 struct cb_field *fld = CB_FIELD (current_field->external_definition);
1629 cb_error_x (CB_TREE(current_field), _("illegal combination of %s with other clauses"),
1630 fld->flag_is_typedef ? "TYPE TO" : "SAME AS");
1631 current_field->flag_is_verified = 1;
1632 current_field->flag_invalid = 1;
1633 } else {
1634 struct cb_field *fld = CB_FIELD (current_field->external_definition);
1635 int new_level = lvl ? cb_get_level (lvl) : 0;
1636 int old_level = current_field->level;
1637 copy_into_field (fld, current_field);
1638 if (new_level > 1 && new_level < 66 && new_level > old_level) {
1639 cb_error_x (lvl, _("entry following %s may not be subordinate to it"),
1640 fld->flag_is_typedef ? "TYPE TO" : "SAME AS");
1641 }
1642 }
1643 }
1644
1645 static cb_tree
get_finalized_description_tree(void)1646 get_finalized_description_tree (void)
1647 {
1648 struct cb_field *p;
1649
1650 /* finalize last field if target of SAME AS / TYPEDEF */
1651 if (current_field && !CB_INVALID_TREE (current_field->external_definition)) {
1652 inherit_external_definition (NULL);
1653 }
1654
1655 /* validate the complete current "block" */
1656 for (p = description_field; p; p = p->sister) {
1657 cb_validate_field (p);
1658 }
1659 return CB_TREE (description_field);
1660 }
1661
1662 static void
check_not_both(const cob_flags_t flag1,const cob_flags_t flag2,const char * flag1_name,const char * flag2_name,const cob_flags_t flags,const cob_flags_t flag_to_set)1663 check_not_both (const cob_flags_t flag1, const cob_flags_t flag2,
1664 const char *flag1_name, const char *flag2_name,
1665 const cob_flags_t flags, const cob_flags_t flag_to_set)
1666 {
1667 if (flag_to_set == flag1 && (flags & flag2)) {
1668 cb_error (_("cannot specify both %s and %s"),
1669 flag1_name, flag2_name);
1670 } else if (flag_to_set == flag2 && (flags & flag1)) {
1671 cb_error (_("cannot specify both %s and %s"),
1672 flag1_name, flag2_name);
1673
1674 }
1675 }
1676
1677 static COB_INLINE COB_A_INLINE void
check_not_highlight_and_lowlight(const cob_flags_t flags,const cob_flags_t flag_to_set)1678 check_not_highlight_and_lowlight (const cob_flags_t flags,
1679 const cob_flags_t flag_to_set)
1680 {
1681 check_not_both (COB_SCREEN_HIGHLIGHT, COB_SCREEN_LOWLIGHT,
1682 "HIGHLIGHT", "LOWLIGHT", flags, flag_to_set);
1683 }
1684
1685 static void
set_screen_attr(const char * clause,const cob_flags_t bitval)1686 set_screen_attr (const char *clause, const cob_flags_t bitval)
1687 {
1688 if (current_field->screen_flag & bitval) {
1689 emit_duplicate_clause_message (clause);
1690 } else {
1691 current_field->screen_flag |= bitval;
1692 }
1693 }
1694
1695 static void
set_attr_with_conflict(const char * clause,const cob_flags_t bitval,const char * confl_clause,const cob_flags_t confl_bit,const int local_check_duplicate,cob_flags_t * flags)1696 set_attr_with_conflict (const char *clause, const cob_flags_t bitval,
1697 const char *confl_clause, const cob_flags_t confl_bit,
1698 const int local_check_duplicate, cob_flags_t *flags)
1699 {
1700 if (local_check_duplicate && (*flags & bitval)) {
1701 emit_duplicate_clause_message (clause);
1702 } else if (*flags & confl_bit) {
1703 emit_conflicting_clause_message (clause, confl_clause);
1704 } else {
1705 *flags |= bitval;
1706 }
1707 }
1708
1709 static COB_INLINE COB_A_INLINE void
set_screen_attr_with_conflict(const char * clause,const cob_flags_t bitval,const char * confl_clause,const cob_flags_t confl_bit)1710 set_screen_attr_with_conflict (const char *clause, const cob_flags_t bitval,
1711 const char *confl_clause,
1712 const cob_flags_t confl_bit)
1713 {
1714 set_attr_with_conflict (clause, bitval, confl_clause, confl_bit, 1,
1715 ¤t_field->screen_flag);
1716 }
1717
1718 static COB_INLINE COB_A_INLINE int
has_dispattr(const cob_flags_t attrib)1719 has_dispattr (const cob_flags_t attrib)
1720 {
1721 return current_statement->attr_ptr
1722 && current_statement->attr_ptr->dispattrs & attrib;
1723 }
1724
1725 static void
attach_attrib_to_cur_stmt(void)1726 attach_attrib_to_cur_stmt (void)
1727 {
1728 if (!current_statement->attr_ptr) {
1729 current_statement->attr_ptr =
1730 cobc_parse_malloc (sizeof(struct cb_attr_struct));
1731 }
1732 }
1733
1734 static COB_INLINE COB_A_INLINE void
set_dispattr(const cob_flags_t attrib)1735 set_dispattr (const cob_flags_t attrib)
1736 {
1737 attach_attrib_to_cur_stmt ();
1738 current_statement->attr_ptr->dispattrs |= attrib;
1739 }
1740
1741 static COB_INLINE COB_A_INLINE void
set_dispattr_with_conflict(const char * attrib_name,const cob_flags_t attrib,const char * confl_name,const cob_flags_t confl_attrib)1742 set_dispattr_with_conflict (const char *attrib_name, const cob_flags_t attrib,
1743 const char *confl_name,
1744 const cob_flags_t confl_attrib)
1745 {
1746 attach_attrib_to_cur_stmt ();
1747 set_attr_with_conflict (attrib_name, attrib, confl_name, confl_attrib, 0,
1748 ¤t_statement->attr_ptr->dispattrs);
1749 }
1750
1751 static void
bit_set_attr(const cb_tree on_off,const cob_flags_t attr_val)1752 bit_set_attr (const cb_tree on_off, const cob_flags_t attr_val)
1753 {
1754 if (on_off == cb_int1) {
1755 set_attr_val_on |= attr_val;
1756 } else {
1757 set_attr_val_off |= attr_val;
1758 }
1759 }
1760
1761 static void
set_field_attribs(cb_tree fgc,cb_tree bgc,cb_tree scroll,cb_tree timeout,cb_tree prompt,cb_tree size_is)1762 set_field_attribs (cb_tree fgc, cb_tree bgc, cb_tree scroll,
1763 cb_tree timeout, cb_tree prompt, cb_tree size_is)
1764 {
1765 /* [WITH] FOREGROUND-COLOR [IS] */
1766 if (fgc) {
1767 current_statement->attr_ptr->fgc = fgc;
1768 }
1769 /* [WITH] BACKGROUND-COLOR [IS] */
1770 if (bgc) {
1771 current_statement->attr_ptr->bgc = bgc;
1772 }
1773 /* [WITH] SCROLL UP | DOWN */
1774 if (scroll) {
1775 current_statement->attr_ptr->scroll = scroll;
1776 }
1777 /* [WITH] TIME-OUT [AFTER] */
1778 if (timeout) {
1779 current_statement->attr_ptr->timeout = timeout;
1780 }
1781 /* [WITH] PROMPT CHARACTER [IS] */
1782 if (prompt) {
1783 current_statement->attr_ptr->prompt = prompt;
1784 }
1785 /* [WITH] SIZE [IS] */
1786 if (size_is) {
1787 current_statement->attr_ptr->size_is = size_is;
1788 }
1789 }
1790
1791 static void
set_attribs(cb_tree fgc,cb_tree bgc,cb_tree scroll,cb_tree timeout,cb_tree prompt,cb_tree size_is,const cob_flags_t attrib)1792 set_attribs (cb_tree fgc, cb_tree bgc, cb_tree scroll,
1793 cb_tree timeout, cb_tree prompt, cb_tree size_is,
1794 const cob_flags_t attrib)
1795 {
1796 attach_attrib_to_cur_stmt ();
1797 set_field_attribs (fgc, bgc, scroll, timeout, prompt, size_is);
1798
1799 current_statement->attr_ptr->dispattrs |= attrib;
1800 }
1801
1802 static void
set_attribs_with_conflict(cb_tree fgc,cb_tree bgc,cb_tree scroll,cb_tree timeout,cb_tree prompt,cb_tree size_is,const char * clause_name,const cob_flags_t attrib,const char * confl_name,const cob_flags_t confl_attrib)1803 set_attribs_with_conflict (cb_tree fgc, cb_tree bgc, cb_tree scroll,
1804 cb_tree timeout, cb_tree prompt, cb_tree size_is,
1805 const char *clause_name, const cob_flags_t attrib,
1806 const char *confl_name, const cob_flags_t confl_attrib)
1807 {
1808 attach_attrib_to_cur_stmt ();
1809 set_field_attribs (fgc, bgc, scroll, timeout, prompt, size_is);
1810
1811 set_dispattr_with_conflict (clause_name, attrib, confl_name,
1812 confl_attrib);
1813 }
1814
1815 static cob_flags_t
zero_conflicting_flag(const cob_flags_t screen_flag,cob_flags_t parent_flag,const cob_flags_t flag1,const cob_flags_t flag2)1816 zero_conflicting_flag (const cob_flags_t screen_flag, cob_flags_t parent_flag,
1817 const cob_flags_t flag1, const cob_flags_t flag2)
1818 {
1819 if (screen_flag & flag1) {
1820 parent_flag &= ~flag2;
1821 } else if (screen_flag & flag2) {
1822 parent_flag &= ~flag1;
1823 }
1824
1825 return parent_flag;
1826 }
1827
1828 static cob_flags_t
zero_conflicting_flags(const cob_flags_t screen_flag,cob_flags_t parent_flag)1829 zero_conflicting_flags (const cob_flags_t screen_flag, cob_flags_t parent_flag)
1830 {
1831 parent_flag = zero_conflicting_flag (screen_flag, parent_flag,
1832 COB_SCREEN_BLANK_LINE,
1833 COB_SCREEN_BLANK_SCREEN);
1834 parent_flag = zero_conflicting_flag (screen_flag, parent_flag,
1835 COB_SCREEN_ERASE_EOL,
1836 COB_SCREEN_ERASE_EOS);
1837 parent_flag = zero_conflicting_flag (screen_flag, parent_flag,
1838 COB_SCREEN_HIGHLIGHT,
1839 COB_SCREEN_LOWLIGHT);
1840
1841 return parent_flag;
1842 }
1843
1844 static void
check_and_set_usage(const enum cb_usage usage)1845 check_and_set_usage (const enum cb_usage usage)
1846 {
1847 check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate);
1848 current_field->usage = usage;
1849 }
1850
1851 static void
check_preceding_tallying_phrases(const enum tallying_phrase phrase)1852 check_preceding_tallying_phrases (const enum tallying_phrase phrase)
1853 {
1854 switch (phrase) {
1855 case FOR_PHRASE:
1856 if (previous_tallying_phrase == ALL_LEADING_TRAILING_PHRASES) {
1857 cb_error (_("FOR phrase cannot immediately follow ALL/LEADING/TRAILING"));
1858 } else if (previous_tallying_phrase == FOR_PHRASE) {
1859 cb_error (_("missing CHARACTERS/ALL/LEADING/TRAILING phrase after FOR phrase"));
1860 }
1861 break;
1862
1863 case ALL_LEADING_TRAILING_PHRASES:
1864 if (previous_tallying_phrase == CHARACTERS_PHRASE
1865 || previous_tallying_phrase == ALL_LEADING_TRAILING_PHRASES) {
1866 cb_error (_("missing value between ALL/LEADING/TRAILING words"));
1867 }
1868 /* fall through */
1869 case CHARACTERS_PHRASE:
1870 if (previous_tallying_phrase == NO_PHRASE) {
1871 cb_error (_("missing FOR phrase before CHARACTERS/ALL/LEADING/TRAILING phrase"));
1872 }
1873 break;
1874
1875 case VALUE_REGION_PHRASE:
1876 if (!(previous_tallying_phrase == ALL_LEADING_TRAILING_PHRASES
1877 || previous_tallying_phrase == VALUE_REGION_PHRASE)) {
1878 cb_error (_("missing ALL/LEADING/TRAILING before value"));
1879 }
1880 break;
1881
1882 /* LCOV_EXCL_START */
1883 default:
1884 /* This should never happen (and therefore doesn't get a translation) */
1885 cb_error ("unexpected tallying phrase");
1886 COBC_ABORT();
1887 /* LCOV_EXCL_STOP */
1888 }
1889
1890 previous_tallying_phrase = phrase;
1891 }
1892
1893 static int
has_relative_pos(struct cb_field const * field)1894 has_relative_pos (struct cb_field const *field)
1895 {
1896 return !!(field->screen_flag
1897 & (COB_SCREEN_LINE_PLUS | COB_SCREEN_LINE_MINUS
1898 | COB_SCREEN_COLUMN_PLUS | COB_SCREEN_COLUMN_MINUS));
1899 }
1900
1901 static int
is_recursive_call(cb_tree target)1902 is_recursive_call (cb_tree target)
1903 {
1904 const char *target_name = "";
1905
1906 if (CB_LITERAL_P (target)) {
1907 target_name = (const char *)(CB_LITERAL(target)->data);
1908 } else if (CB_REFERENCE_P (target)
1909 && CB_PROTOTYPE_P (cb_ref (target))) {
1910 target_name = CB_PROTOTYPE (cb_ref (target))->ext_name;
1911 }
1912
1913 return !strcmp (target_name, current_program->orig_program_id);
1914 }
1915
1916 static cb_tree
check_not_88_level(cb_tree x)1917 check_not_88_level (cb_tree x)
1918 {
1919 struct cb_field *f;
1920
1921 if (x == cb_error_node) {
1922 return cb_error_node;
1923 }
1924 if (!CB_REF_OR_FIELD_P(x)) {
1925 return x;
1926 }
1927
1928 f = CB_FIELD_PTR (x);
1929
1930 if (f->level == 88) {
1931 #if 0 /* note: we may consider to support the extension (if existing) to
1932 reference a condition-name target by the condition-name */
1933 if (cb_verify (cb_condition_references_data, _("use of condition-name in place of data-name"))) {
1934 return CB_TREE (f->parent);
1935 }
1936 #else
1937 cb_error (_("condition-name not allowed here: '%s'"), cb_name (x));
1938 /* invalidate field to prevent same error in typeck.c (validate_one) */
1939 /* FIXME: If we really need the additional check here then we missed
1940 a call to cb_validate_one() somewhere */
1941 return cb_error_node;
1942 #endif
1943 } else {
1944 return x;
1945 }
1946 }
1947
1948 static int
is_screen_field(cb_tree x)1949 is_screen_field (cb_tree x)
1950 {
1951 if (CB_FIELD_P (x)) {
1952 return (CB_FIELD (x))->storage == CB_STORAGE_SCREEN;
1953 } else if (CB_REFERENCE_P (x)) {
1954 return is_screen_field (cb_ref (x));
1955 } else {
1956 return 0;
1957 }
1958 }
1959
1960 static void
error_if_no_advancing_in_screen_display(cb_tree advancing)1961 error_if_no_advancing_in_screen_display (cb_tree advancing)
1962 {
1963 if (advancing != cb_int1) {
1964 cb_error (_("cannot specify NO ADVANCING in screen DISPLAY"));
1965 }
1966 }
1967
1968 static cb_tree
get_default_display_device(void)1969 get_default_display_device (void)
1970 {
1971 if (current_program->flag_console_is_crt
1972 || cb_console_is_crt) {
1973 return cb_null;
1974 } else {
1975 return cb_int0;
1976 }
1977 }
1978
1979 static COB_INLINE COB_A_INLINE int
contains_one_screen_field(struct cb_list * x_list)1980 contains_one_screen_field (struct cb_list *x_list)
1981 {
1982 return (cb_tree) x_list != cb_null
1983 && cb_list_length ((cb_tree) x_list) == 1
1984 && is_screen_field (x_list->value);
1985 }
1986
1987 static int
contains_only_screen_fields(struct cb_list * x_list)1988 contains_only_screen_fields (struct cb_list *x_list)
1989 {
1990 if ((cb_tree) x_list == cb_null) {
1991 return 0;
1992 }
1993
1994 for (; x_list; x_list = (struct cb_list *) x_list->chain) {
1995 if (!is_screen_field (x_list->value)) {
1996 return 0;
1997 }
1998 }
1999
2000 return 1;
2001 }
2002
2003 static int
contains_fields_and_screens(struct cb_list * x_list)2004 contains_fields_and_screens (struct cb_list *x_list)
2005 {
2006 int field_seen = 0;
2007 int screen_seen = 0;
2008
2009 if ((cb_tree) x_list == cb_null) {
2010 return 0;
2011 }
2012
2013 for (; x_list; x_list = (struct cb_list *) x_list->chain) {
2014 if (is_screen_field (x_list->value)) {
2015 screen_seen = 1;
2016 } else {
2017 field_seen = 1;
2018 }
2019 }
2020
2021 return screen_seen && field_seen;
2022 }
2023
2024 static enum cb_display_type
deduce_display_type(cb_tree x_list,cb_tree local_upon_value,cb_tree local_line_column,struct cb_attr_struct * const attr_ptr)2025 deduce_display_type (cb_tree x_list, cb_tree local_upon_value, cb_tree local_line_column,
2026 struct cb_attr_struct * const attr_ptr)
2027 {
2028 int using_default_device_which_is_crt =
2029 local_upon_value == NULL && get_default_display_device () == cb_null;
2030
2031 /* TODO: Separate CGI DISPLAYs here */
2032 if (contains_only_screen_fields ((struct cb_list *) x_list)) {
2033 if (!contains_one_screen_field ((struct cb_list *) x_list)
2034 || attr_ptr) {
2035 cb_verify_x (x_list, cb_accept_display_extensions,
2036 _("non-standard DISPLAY"));
2037 }
2038
2039 if (local_upon_value != NULL && local_upon_value != cb_null) {
2040 cb_error_x (x_list, _("screens may only be displayed on CRT"));
2041 }
2042
2043 return SCREEN_DISPLAY;
2044 } else if (contains_fields_and_screens ((struct cb_list *) x_list)) {
2045 cb_error_x (x_list, _("cannot mix screens and fields in the same DISPLAY statement"));
2046 return MIXED_DISPLAY;
2047 } else if (local_line_column || attr_ptr) {
2048 if (local_upon_value != NULL && local_upon_value != cb_null) {
2049 cb_error_x (x_list, _("screen clauses may only be used for DISPLAY on CRT"));
2050 }
2051
2052 cb_verify_x (x_list, cb_accept_display_extensions,
2053 _("non-standard DISPLAY"));
2054
2055 return FIELD_ON_SCREEN_DISPLAY;
2056 } else if (local_upon_value == cb_null || using_default_device_which_is_crt) {
2057 /* This is the only format permitted by the standard */
2058 return FIELD_ON_SCREEN_DISPLAY;
2059 } else if (display_type == FIELD_ON_SCREEN_DISPLAY && local_upon_value == NULL) {
2060 /* This is for when fields without clauses follow fields with screen clauses */
2061 return FIELD_ON_SCREEN_DISPLAY;
2062 } else {
2063 return DEVICE_DISPLAY;
2064 }
2065 }
2066
2067 static void
set_display_type(cb_tree x_list,cb_tree local_upon_value,cb_tree local_line_column,struct cb_attr_struct * const attr_ptr)2068 set_display_type (cb_tree x_list, cb_tree local_upon_value,
2069 cb_tree local_line_column, struct cb_attr_struct * const attr_ptr)
2070 {
2071 display_type = deduce_display_type (x_list, local_upon_value, local_line_column, attr_ptr);
2072 }
2073
2074 static void
error_if_different_display_type(cb_tree x_list,cb_tree local_upon_value,cb_tree local_line_column,struct cb_attr_struct * const attr_ptr)2075 error_if_different_display_type (cb_tree x_list, cb_tree local_upon_value,
2076 cb_tree local_line_column, struct cb_attr_struct * const attr_ptr)
2077 {
2078 const enum cb_display_type type =
2079 deduce_display_type (x_list, local_upon_value, local_line_column, attr_ptr);
2080
2081 /* Avoid re-displaying the same error for mixed DISPLAYs */
2082 if (type == display_type || display_type == MIXED_DISPLAY) {
2083 return;
2084 }
2085
2086 if (type != MIXED_DISPLAY) {
2087 if (type == SCREEN_DISPLAY || display_type == SCREEN_DISPLAY) {
2088 cb_error_x (x_list, _("cannot mix screens and fields in the same DISPLAY statement"));
2089 } else {
2090 /*
2091 The only other option is that there is a mix of
2092 FIELD_ON_SCREEN_DISPLAY and DEVICE_DISPLAY.
2093 */
2094 cb_error_x (x_list, _("ambiguous DISPLAY; put items to display on device in separate DISPLAY"));
2095 }
2096 }
2097
2098 display_type = MIXED_DISPLAY;
2099 }
2100
2101 static void
error_if_not_usage_display_or_nonnumeric_lit(cb_tree x)2102 error_if_not_usage_display_or_nonnumeric_lit (cb_tree x)
2103 {
2104 const int is_numeric_literal = CB_NUMERIC_LITERAL_P (x);
2105 const int is_field_with_usage_not_display =
2106 CB_REFERENCE_P (x) && CB_FIELD (cb_ref (x))
2107 && CB_FIELD (cb_ref (x))->usage != CB_USAGE_DISPLAY;
2108
2109 if (is_numeric_literal) {
2110 cb_error_x (x, _("%s is not an alphanumeric literal"), CB_LITERAL (x)->data);
2111 } else if (is_field_with_usage_not_display) {
2112 cb_error_x (x, _("'%s' is not USAGE DISPLAY"), cb_name (x));
2113 }
2114 }
2115
2116 static void
check_validate_item(cb_tree x)2117 check_validate_item (cb_tree x)
2118 {
2119 struct cb_field *f;
2120 enum cb_class tree_class;
2121
2122 if (CB_INVALID_TREE(x) || x->tag != CB_TAG_REFERENCE) {
2123 return;
2124 }
2125 x = cb_ref (x);
2126 if (CB_INVALID_TREE (x) || !CB_FIELD_P (x)) {
2127 cb_error (_("invalid target for %s"), "VALIDATE");
2128 return;
2129 }
2130
2131 f = CB_FIELD (x);
2132 tree_class = CB_TREE_CLASS(f);
2133 if (is_screen_field(x)) {
2134 cb_error (_("SCREEN item cannot be used here"));
2135 } else if (f->level == 66) {
2136 cb_error (_("RENAMES item may not be used here"));
2137 } else if (f->flag_any_length) {
2138 cb_error (_("ANY LENGTH item not allowed here"));
2139 } else if (tree_class == CB_CLASS_INDEX
2140 || tree_class == CB_CLASS_OBJECT
2141 || tree_class == CB_CLASS_POINTER) {
2142 cb_error (_("item '%s' has wrong class for VALIDATE"), cb_name (x));
2143 }
2144 }
2145
2146 static void
error_if_following_every_clause(void)2147 error_if_following_every_clause (void)
2148 {
2149 if (ml_suppress_list
2150 && CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list))->target == CB_ML_SUPPRESS_TYPE) {
2151 cb_error (_("WHEN clause must follow EVERY clause"));
2152 }
2153 }
2154
2155 static void
prepend_to_ml_suppress_list(cb_tree suppress_entry)2156 prepend_to_ml_suppress_list (cb_tree suppress_entry)
2157 {
2158 cb_tree new_list_head = CB_LIST_INIT (suppress_entry);
2159 cb_list_append (new_list_head, ml_suppress_list);
2160 ml_suppress_list = new_list_head;
2161 }
2162
2163 static void
add_identifier_to_ml_suppress_conds(cb_tree identifier)2164 add_identifier_to_ml_suppress_conds (cb_tree identifier)
2165 {
2166 cb_tree suppress_id = cb_build_ml_suppress_clause ();
2167 CB_ML_SUPPRESS (suppress_id)->target = CB_ML_SUPPRESS_IDENTIFIER;
2168 CB_ML_SUPPRESS (suppress_id)->identifier = identifier;
2169 prepend_to_ml_suppress_list (suppress_id);
2170 }
2171
2172 static void
add_when_to_ml_suppress_conds(cb_tree when_list)2173 add_when_to_ml_suppress_conds (cb_tree when_list)
2174 {
2175 struct cb_ml_suppress_clause *last_suppress_clause;
2176 cb_tree suppress_all;
2177
2178 /*
2179 If the preceding clause in SUPPRESS was an identifier, the WHEN
2180 belongs to the identifier. If EVERY was preceding, the WHEN belongs to
2181 the EVERY. Otherwise, the WHEN acts on the entire record.
2182 */
2183 if (ml_suppress_list) {
2184 last_suppress_clause = CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list));
2185 if ((last_suppress_clause->target == CB_ML_SUPPRESS_IDENTIFIER
2186 || last_suppress_clause->target == CB_ML_SUPPRESS_TYPE)
2187 && !last_suppress_clause->when_list) {
2188 last_suppress_clause->when_list = when_list;
2189 return;
2190 }
2191 }
2192
2193 suppress_all = cb_build_ml_suppress_clause ();
2194 CB_ML_SUPPRESS (suppress_all)->when_list = when_list;
2195 prepend_to_ml_suppress_list (suppress_all);
2196 }
2197
2198 static void
add_type_to_ml_suppress_conds(enum cb_ml_suppress_category category,enum cb_ml_type ml_type)2199 add_type_to_ml_suppress_conds (enum cb_ml_suppress_category category,
2200 enum cb_ml_type ml_type)
2201 {
2202 cb_tree suppress_type = cb_build_ml_suppress_clause ();
2203 CB_ML_SUPPRESS (suppress_type)->target = CB_ML_SUPPRESS_TYPE;
2204 CB_ML_SUPPRESS (suppress_type)->category = category;
2205 CB_ML_SUPPRESS (suppress_type)->ml_type = ml_type;
2206 prepend_to_ml_suppress_list (suppress_type);
2207 }
2208
2209 static void
set_record_size(cb_tree min,cb_tree max)2210 set_record_size (cb_tree min, cb_tree max)
2211 {
2212 int record_min, record_max;
2213
2214 if (min) {
2215 record_min = cb_get_int (min);
2216 if (record_min < 0) {
2217 /* already handled by integer check */
2218 } else {
2219 current_file->record_min = record_min;
2220 }
2221 } else {
2222 record_min = 0;
2223 }
2224 if (!max) {
2225 return;
2226 }
2227
2228 record_max = cb_get_int (max);
2229 if (record_max < 0) {
2230 /* already handled by integer check */
2231 return;
2232 } else if (record_max == 0) {
2233 /* Note: standard COBOL does not allow zero at all, use the related
2234 configuration option */
2235 if (cb_records_mismatch_record_clause >= CB_ERROR) {
2236 cb_error (_("non-zero value expected"));
2237 }
2238 return;
2239 }
2240 if (current_file->organization == COB_ORG_INDEXED
2241 && record_max > MAX_FD_RECORD_IDX) {
2242 cb_error (_("RECORD size (IDX) exceeds maximum allowed (%d)"),
2243 MAX_FD_RECORD_IDX);
2244 current_file->record_max = MAX_FD_RECORD_IDX;
2245 } else if (record_max > MAX_FD_RECORD) {
2246 cb_error (_("RECORD size exceeds maximum allowed (%d)"),
2247 MAX_FD_RECORD);
2248 current_file->record_max = MAX_FD_RECORD;
2249 } else {
2250 if (record_max <= record_min) {
2251 cb_error (_("RECORD clause invalid"));
2252 }
2253 current_file->record_max = record_max;
2254 }
2255 }
2256
2257 %}
2258
2259 %token TOKEN_EOF 0 "end of file"
2260
2261 %token THREEDIMENSIONAL "3D"
2262 %token ABSENT
2263 %token ACCEPT
2264 %token ACCESS
2265 %token ACTIVEX "ACTIVE-X"
2266 %token ACTION
2267 %token ACTUAL
2268 %token ADD
2269 %token ADDRESS
2270 %token ADJUSTABLE_COLUMNS "ADJUSTABLE-COLUMNS"
2271 %token ADVANCING
2272 %token AFTER
2273 %token ALIGNMENT
2274 %token ALL
2275 %token ALLOCATE
2276 %token ALLOWING
2277 %token ALPHABET
2278 %token ALPHABETIC
2279 %token ALPHABETIC_LOWER "ALPHABETIC-LOWER"
2280 %token ALPHABETIC_UPPER "ALPHABETIC-UPPER"
2281 %token ALPHANUMERIC
2282 %token ALPHANUMERIC_EDITED "ALPHANUMERIC-EDITED"
2283 %token ALSO
2284 %token ALTER
2285 %token ALTERNATE
2286 %token AND
2287 %token ANY
2288 %token APPLY
2289 %token ARE
2290 %token AREA
2291 %token AREAS
2292 %token ARGUMENT_NUMBER "ARGUMENT-NUMBER"
2293 %token ARGUMENT_VALUE "ARGUMENT-VALUE"
2294 %token ARITHMETIC
2295 %token AS
2296 %token ASCENDING
2297 %token ASCII
2298 %token ASSIGN
2299 %token AT
2300 %token ATTRIBUTE
2301 %token ATTRIBUTES
2302 %token AUTO
2303 %token AUTO_DECIMAL "AUTO-DECIMAL"
2304 %token AUTO_SPIN "AUTO-SPIN"
2305 %token AUTOMATIC
2306 %token AWAY_FROM_ZERO "AWAY-FROM-ZERO"
2307 %token BACKGROUND_COLOR "BACKGROUND-COLOR"
2308 %token BACKGROUND_HIGH "BACKGROUND-HIGH"
2309 %token BACKGROUND_LOW "BACKGROUND-LOW"
2310 %token BACKGROUND_STANDARD "BACKGROUND-STANDARD"
2311 %token BAR
2312 %token BASED
2313 %token BEFORE
2314 %token BELL
2315 %token BINARY
2316 %token BINARY_C_LONG "BINARY-C-LONG"
2317 %token BINARY_CHAR "BINARY-CHAR"
2318 %token BINARY_DOUBLE "BINARY-DOUBLE"
2319 %token BINARY_LONG "BINARY-LONG"
2320 %token BINARY_SEQUENTIAL "BINARY-SEQUENTIAL"
2321 %token BINARY_SHORT "BINARY-SHORT"
2322 %token BIT
2323 %token BITMAP
2324 %token BITMAP_END "BITMAP-END"
2325 %token BITMAP_HANDLE "BITMAP-HANDLE"
2326 %token BITMAP_NUMBER "BITMAP-NUMBER"
2327 %token BITMAP_START "BITMAP-START"
2328 %token BITMAP_TIMER "BITMAP-TIMER"
2329 %token BITMAP_TRAILING "BITMAP-TRAILING"
2330 %token BITMAP_TRANSPARENT_COLOR "BITMAP-TRANSPARENT-COLOR"
2331 %token BITMAP_WIDTH "BITMAP-WIDTH"
2332 %token BLANK
2333 %token BLINK
2334 %token BLOCK
2335 %token BOTTOM
2336 %token BOX
2337 %token BOXED
2338 %token BULK_ADDITION "BULK-ADDITION"
2339 %token BUSY
2340 %token BUTTONS
2341 %token BY
2342 %token BYTE_LENGTH "BYTE-LENGTH"
2343 %token C
2344 %token CALENDAR_FONT "CALENDAR-FONT"
2345 %token CALL
2346 %token CANCEL
2347 %token CANCEL_BUTTON "CANCEL-BUTTON"
2348 %token CAPACITY
2349 %token CARD_PUNCH "CARD-PUNCH"
2350 %token CARD_READER "CARD-READER"
2351 %token CASSETTE
2352 %token CCOL
2353 %token CD
2354 %token CELL
2355 %token CELL_COLOR "CELL-COLOR"
2356 %token CELL_DATA "CELL-DATA"
2357 %token CELL_FONT "CELL-FONT"
2358 %token CELL_PROTECTION "CELL-PROTECTION"
2359 %token CENTER
2360 %token CENTERED
2361 %token CENTERED_HEADINGS "CENTERED-HEADINGS"
2362 %token CENTURY_DATE "CENTURY-DATE"
2363 %token CF
2364 %token CH
2365 %token CHAINING
2366 %token CHANGED
2367 %token CHARACTER
2368 %token CHARACTERS
2369 %token CHECK_BOX "CHECK-BOX"
2370 %token CLASS
2371 %token CLASSIFICATION
2372 %token CLASS_NAME "class-name"
2373 %token CLEAR_SELECTION "CLEAR-SELECTION"
2374 %token CLINE
2375 %token CLINES
2376 %token CLOSE
2377 %token COBOL
2378 %token CODE
2379 %token CODE_SET "CODE-SET"
2380 %token COLLATING
2381 %token COL
2382 %token COLOR
2383 %token COLORS
2384 %token COLS
2385 %token COLUMN
2386 %token COLUMN_COLOR "COLUMN-COLOR"
2387 %token COLUMN_DIVIDERS "COLUMN-DIVIDERS"
2388 %token COLUMN_FONT "COLUMN-FONT"
2389 %token COLUMN_HEADINGS "COLUMN-HEADINGS"
2390 %token COLUMN_PROTECTION "COLUMN-PROTECTION"
2391 %token COLUMNS
2392 %token COMBO_BOX "COMBO-BOX"
2393 %token COMMA
2394 %token COMMAND_LINE "COMMAND-LINE"
2395 %token COMMA_DELIM "comma delimiter"
2396 %token COMMIT
2397 %token COMMON
2398 %token COMMUNICATION
2399 %token COMP
2400 %token COMPUTE
2401 %token COMP_0 "COMP-0"
2402 %token COMP_1 "COMP-1"
2403 %token COMP_2 "COMP-2"
2404 %token COMP_3 "COMP-3"
2405 %token COMP_4 "COMP-4"
2406 %token COMP_5 "COMP-5"
2407 %token COMP_6 "COMP-6"
2408 %token COMP_N "COMP-N"
2409 %token COMP_X "COMP-X"
2410 %token CONCATENATE_FUNC "FUNCTION CONCATENATE"
2411 %token CONDITION
2412 %token CONFIGURATION
2413 %token CONSTANT
2414 %token CONTAINS
2415 %token CONTENT
2416 %token CONTENT_LENGTH_FUNC "FUNCTION CONTENT-LENGTH"
2417 %token CONTENT_OF_FUNC "FUNCTION CONTENT-OF"
2418 %token CONTINUE
2419 %token CONTROL
2420 %token CONTROLS
2421 %token CONVERSION
2422 %token CONVERTING
2423 %token COPY
2424 %token COPY_SELECTION "COPY-SELECTION"
2425 %token CORE_INDEX "CORE-INDEX"
2426 %token CORRESPONDING
2427 %token COUNT
2428 %token CRT
2429 %token CRT_UNDER "CRT-UNDER"
2430 %token CSIZE
2431 %token CURRENCY
2432 %token CURRENT_DATE_FUNC "FUNCTION CURRENT-DATE"
2433 %token CURSOR
2434 %token CURSOR_COL "CURSOR-COL"
2435 %token CURSOR_COLOR "CURSOR-COLOR"
2436 %token CURSOR_FRAME_WIDTH "CURSOR-FRAME-WIDTH"
2437 %token CURSOR_ROW "CURSOR-ROW"
2438 %token CURSOR_X "CURSOR-X"
2439 %token CURSOR_Y "CURSOR-Y"
2440 %token CUSTOM_PRINT_TEMPLATE "CUSTOM-PRINT-TEMPLATE"
2441 %token CYCLE
2442 %token CYL_INDEX "CYL-INDEX"
2443 %token CYL_OVERFLOW "CYL-OVERFLOW"
2444 %token DASHED
2445 %token DATA
2446 %token DATA_COLUMNS "DATA-COLUMNS"
2447 %token DATA_TYPES "DATA-TYPES"
2448 %token DATE
2449 %token DATE_ENTRY "DATE-ENTRY"
2450 %token DAY
2451 %token DAY_OF_WEEK "DAY-OF-WEEK"
2452 %token DE
2453 %token DEBUGGING
2454 %token DECIMAL_POINT "DECIMAL-POINT"
2455 %token DECLARATIVES
2456 %token DEFAULT
2457 %token DEFAULT_BUTTON "DEFAULT-BUTTON"
2458 %token DEFAULT_FONT "DEFAULT-FONT"
2459 %token DELETE
2460 %token DELIMITED
2461 %token DELIMITER
2462 %token DEPENDING
2463 %token DESCENDING
2464 %token DESTINATION
2465 %token DESTROY
2466 %token DETAIL
2467 %token DISABLE
2468 %token DISC
2469 %token DISK
2470 %token DISP
2471 %token DISPLAY
2472 %token DISPLAY_COLUMNS "DISPLAY-COLUMNS"
2473 %token DISPLAY_FORMAT "DISPLAY-FORMAT"
2474 %token DISPLAY_OF_FUNC "FUNCTION DISPLAY-OF"
2475 %token DIVIDE
2476 %token DIVIDERS
2477 %token DIVIDER_COLOR "DIVIDER-COLOR"
2478 %token DIVISION
2479 %token DOTDASH
2480 %token DOTTED
2481 %token DRAG_COLOR "DRAG-COLOR"
2482 %token DROP_DOWN "DROP-DOWN"
2483 %token DROP_LIST "DROP-LIST"
2484 %token DOWN
2485 %token DUPLICATES
2486 %token DYNAMIC
2487 %token EBCDIC
2488 %token EC
2489 %token ECHO
2490 %token EGI
2491 %token EIGHTY_EIGHT "level-number 88"
2492 %token ENABLE
2493 %token ELEMENT
2494 %token ELSE
2495 %token EMI
2496 %token ENCRYPTION
2497 %token ENCODING
2498 %token END
2499 %token END_ACCEPT "END-ACCEPT"
2500 %token END_ADD "END-ADD"
2501 %token END_CALL "END-CALL"
2502 %token END_COMPUTE "END-COMPUTE"
2503 %token END_COLOR "END-COLOR"
2504 %token END_DELETE "END-DELETE"
2505 %token END_DISPLAY "END-DISPLAY"
2506 %token END_DIVIDE "END-DIVIDE"
2507 %token END_EVALUATE "END-EVALUATE"
2508 %token END_FUNCTION "END FUNCTION"
2509 %token END_IF "END-IF"
2510 %token END_JSON "END-JSON"
2511 %token END_MODIFY "END-MODIFY"
2512 %token END_MULTIPLY "END-MULTIPLY"
2513 %token END_PERFORM "END-PERFORM"
2514 %token END_PROGRAM "END PROGRAM"
2515 %token END_READ "END-READ"
2516 %token END_RECEIVE "END-RECEIVE"
2517 %token END_RETURN "END-RETURN"
2518 %token END_REWRITE "END-REWRITE"
2519 %token END_SEARCH "END-SEARCH"
2520 %token END_START "END-START"
2521 %token END_STRING "END-STRING"
2522 %token END_SUBTRACT "END-SUBTRACT"
2523 %token END_UNSTRING "END-UNSTRING"
2524 %token END_WRITE "END-WRITE"
2525 %token END_XML "END-XML"
2526 %token ENGRAVED
2527 %token ENSURE_VISIBLE "ENSURE-VISIBLE"
2528 %token ENTRY
2529 %token ENTRY_CONVENTION "ENTRY-CONVENTION"
2530 %token ENTRY_FIELD "ENTRY-FIELD"
2531 %token ENTRY_REASON "ENTRY-REASON"
2532 %token ENVIRONMENT
2533 %token ENVIRONMENT_NAME "ENVIRONMENT-NAME"
2534 %token ENVIRONMENT_VALUE "ENVIRONMENT-VALUE"
2535 %token EOL
2536 %token EOP
2537 %token EOS
2538 %token EQUAL
2539 %token ERASE
2540 %token ERROR
2541 %token ESCAPE
2542 %token ESCAPE_BUTTON "ESCAPE-BUTTON"
2543 %token ESI
2544 %token EVALUATE
2545 %token EVENT
2546 %token EVENT_LIST "EVENT-LIST"
2547 %token EVENT_STATUS "EVENT STATUS"
2548 %token EVERY
2549 %token EXCEPTION
2550 %token EXCEPTION_CONDITION "EXCEPTION CONDITION"
2551 %token EXCEPTION_VALUE "EXCEPTION-VALUE"
2552 %token EXPAND
2553 %token EXCLUSIVE
2554 %token EXHIBIT
2555 %token EXIT
2556 %token EXPONENTIATION "exponentiation operator"
2557 %token EXTEND
2558 %token EXTENDED_SEARCH "EXTENDED-SEARCH"
2559 %token EXTERNAL
2560 %token EXTERNAL_FORM "EXTERNAL-FORM"
2561 %token F
2562 %token FD
2563 %token FH__FCD "FH--FCD"
2564 %token FH__KEYDEF "FH--KEYDEF"
2565 %token FILE_CONTROL "FILE-CONTROL"
2566 %token FILE_ID "FILE-ID"
2567 %token FILE_LIMIT "FILE-LIMIT"
2568 %token FILE_LIMITS "FILE-LIMITS"
2569 %token FILE_NAME "FILE-NAME"
2570 %token FILE_POS "FILE-POS"
2571 %token FILL_COLOR "FILL-COLOR"
2572 %token FILL_COLOR2 "FILL-COLOR2"
2573 %token FILL_PERCENT "FILL-PERCENT"
2574 %token FILLER
2575 %token FINAL
2576 %token FINISH_REASON "FINISH-REASON"
2577 %token FIRST
2578 %token FIXED
2579 %token FIXED_FONT "FIXED-FONT"
2580 %token FIXED_WIDTH "FIXED-WIDTH"
2581 %token FLAT
2582 %token FLAT_BUTTONS "FLAT-BUTTONS"
2583 %token FLOAT_BINARY_128 "FLOAT-BINARY-128"
2584 %token FLOAT_BINARY_32 "FLOAT-BINARY-32"
2585 %token FLOAT_BINARY_64 "FLOAT-BINARY-64"
2586 %token FLOAT_DECIMAL_16 "FLOAT-DECIMAL-16"
2587 %token FLOAT_DECIMAL_34 "FLOAT-DECIMAL-34"
2588 %token FLOAT_DECIMAL_7 "FLOAT-DECIMAL-7"
2589 %token FLOAT_EXTENDED "FLOAT-EXTENDED"
2590 %token FLOAT_LONG "FLOAT-LONG"
2591 %token FLOAT_SHORT "FLOAT-SHORT"
2592 %token FLOATING
2593 %token FONT
2594 %token FOOTING
2595 %token FOR
2596 %token FOREGROUND_COLOR "FOREGROUND-COLOR"
2597 %token FOREVER
2598 %token FORMATTED_DATE_FUNC "FUNCTION FORMATTED-DATE"
2599 %token FORMATTED_DATETIME_FUNC "FUNCTION FORMATTED-DATETIME"
2600 %token FORMATTED_TIME_FUNC "FUNCTION FORMATTED-TIME"
2601 %token FRAME
2602 %token FRAMED
2603 %token FREE
2604 %token FROM
2605 %token FROM_CRT "FROM CRT"
2606 %token FULL
2607 %token FULL_HEIGHT "FULL-HEIGHT"
2608 %token FUNCTION
2609 %token FUNCTION_ID "FUNCTION-ID"
2610 %token FUNCTION_NAME "intrinsic function name"
2611 %token GENERATE
2612 %token GIVING
2613 %token GLOBAL
2614 %token GO
2615 %token GO_BACK "GO-BACK"
2616 %token GO_FORWARD "GO-FORWARD"
2617 %token GO_HOME "GO-HOME"
2618 %token GO_SEARCH "GO-SEARCH"
2619 %token GOBACK
2620 %token GRAPHICAL
2621 %token GREATER
2622 %token GREATER_OR_EQUAL "GREATER OR EQUAL"
2623 %token GRID
2624 %token GROUP
2625 %token GROUP_VALUE "GROUP-VALUE"
2626 %token HANDLE
2627 %token HAS_CHILDREN "HAS-CHILDREN"
2628 %token HEADING
2629 %token HEADING_COLOR "HEADING-COLOR"
2630 %token HEADING_DIVIDER_COLOR "HEADING-DIVIDER-COLOR"
2631 %token HEADING_FONT "HEADING-FONT"
2632 %token HEAVY
2633 %token HEIGHT_IN_CELLS "HEIGHT-IN-CELLS"
2634 %token HIDDEN_DATA "HIDDEN-DATA"
2635 %token HIGHLIGHT
2636 %token HIGH_COLOR "HIGH-COLOR"
2637 %token HIGH_VALUE "HIGH-VALUE"
2638 %token HOT_TRACK "HOT-TRACK"
2639 %token HSCROLL
2640 %token HSCROLL_POS "HSCROLL-POS"
2641 %token ICON
2642 %token ID
2643 %token IDENTIFIED
2644 %token IDENTIFICATION
2645 %token IF
2646 %token IGNORE
2647 %token IGNORING
2648 %token IN
2649 %token INDEPENDENT
2650 %token INDEX
2651 %token INDEXED
2652 %token INDICATE
2653 %token INITIALIZE
2654 %token INITIALIZED
2655 %token INITIATE
2656 %token INPUT
2657 %token INPUT_OUTPUT "INPUT-OUTPUT"
2658 %token INQUIRE
2659 %token INSERTION_INDEX "INSERTION-INDEX"
2660 %token INSERT_ROWS "INSERT-ROWS"
2661 %token INSPECT
2662 %token INTERMEDIATE
2663 %token INTO
2664 %token INTRINSIC
2665 %token INVALID
2666 %token INVALID_KEY "INVALID KEY"
2667 %token IS
2668 %token ITEM
2669 %token ITEM_TEXT "ITEM-TEXT"
2670 %token ITEM_TO_ADD "ITEM-TO_ADD"
2671 %token ITEM_TO_DELETE "ITEM-TO_DELETE"
2672 %token ITEM_TO_EMPTY "ITEM-TO_EMPTY"
2673 %token ITEM_VALUE "ITEM-VALUE"
2674 %token I_O "I-O"
2675 %token I_O_CONTROL "I-O-CONTROL"
2676 %token JSON
2677 %token JUSTIFIED
2678 %token KEPT
2679 %token KEY
2680 %token KEYBOARD
2681 %token LABEL
2682 %token LABEL_OFFSET "LABEL-OFFSET"
2683 %token LARGE_FONT "LARGE-FONT"
2684 %token LARGE_OFFSET "LARGE-OFFSET"
2685 %token LAST
2686 %token LAST_ROW "LAST-ROW"
2687 %token LAYOUT_DATA "LAYOUT-DATA"
2688 %token LAYOUT_MANAGER "LAYOUT-MANAGER"
2689 %token LEADING
2690 %token LEADING_SHIFT "LEADING-SHIFT"
2691 %token LEAVE
2692 %token LEFT
2693 %token LEFTLINE
2694 %token LEFT_TEXT "LEFT-TEXT"
2695 %token LENGTH
2696 %token LENGTH_OF "LENGTH OF"
2697 %token LENGTH_FUNC "FUNCTION LENGTH/BYTE-LENGTH"
2698 %token LESS
2699 %token LESS_OR_EQUAL "LESS OR EQUAL"
2700 %token LEVEL_NUMBER "level-number" /* 01 thru 49, 77 */
2701 %token LIKE
2702 %token LIMIT
2703 %token LIMITS
2704 %token LINAGE
2705 %token LINAGE_COUNTER "LINAGE-COUNTER"
2706 %token LINE
2707 %token LINE_COUNTER "LINE-COUNTER"
2708 %token LINE_LIMIT "LINE LIMIT"
2709 %token LINE_SEQUENTIAL "LINE-SEQUENTIAL"
2710 %token LINES
2711 %token LINES_AT_ROOT "LINES-AT-ROOT"
2712 %token LINKAGE
2713 %token LIST_BOX "LIST-BOX"
2714 %token LITERAL "Literal"
2715 %token LM_RESIZE "LM-RESIZE"
2716 %token LOC
2717 %token LOCALE
2718 %token LOCALE_DATE_FUNC "FUNCTION LOCALE-DATE"
2719 %token LOCALE_TIME_FUNC "FUNCTION LOCALE-TIME"
2720 %token LOCALE_TIME_FROM_FUNC "FUNCTION LOCALE-TIME-FROM-SECONDS"
2721 %token LOCAL_STORAGE "LOCAL-STORAGE"
2722 %token LOCK
2723 %token LOCK_HOLDING "LOCK-HOLDING"
2724 %token LONG_DATE "LONG-DATE"
2725 %token LOWER
2726 %token LOWERED
2727 %token LOWER_CASE_FUNC "FUNCTION LOWER-CASE"
2728 %token LOWLIGHT
2729 %token LOW_COLOR "LOW-COLOR"
2730 %token LOW_VALUE "LOW-VALUE"
2731 %token MAGNETIC_TAPE "MAGNETIC-TAPE"
2732 %token MANUAL
2733 %token MASS_UPDATE "MASS-UPDATE"
2734 %token MASTER_INDEX "MASTER-INDEX"
2735 %token MAX_LINES "MAX-LINES"
2736 %token MAX_PROGRESS "MAX-PROGRESS"
2737 %token MAX_TEXT "MAX-TEXT"
2738 %token MAX_VAL "MAX-VAL"
2739 %token MEMORY
2740 %token MEDIUM_FONT "MEDIUM-FONT"
2741 %token MENU
2742 %token MERGE
2743 %token MESSAGE
2744 %token MINUS
2745 %token MIN_VAL "MIN-VAL"
2746 %token MNEMONIC_NAME "Mnemonic name"
2747 %token MODE
2748 %token MODIFY
2749 %token MODULES
2750 %token MOVE
2751 %token MULTILINE
2752 %token MULTIPLE
2753 %token MULTIPLY
2754 %token NAME
2755 %token NAMED
2756 %token NAMESPACE
2757 %token NAMESPACE_PREFIX "NAMESPACE-PREFIX"
2758 %token NATIONAL
2759 %token NATIONAL_EDITED "NATIONAL-EDITED"
2760 %token NATIONAL_OF_FUNC "FUNCTION NATIONAL-OF"
2761 %token NATIVE
2762 %token NAVIGATE_URL "NAVIGATE-URL"
2763 %token NEAREST_AWAY_FROM_ZERO "NEAREST-AWAY-FROM-ZERO"
2764 %token NEAREST_EVEN "NEAREST-EVEN"
2765 %token NEAREST_TOWARD_ZERO "NEAREST-TOWARD-ZERO"
2766 %token NEGATIVE
2767 %token NESTED
2768 %token NEW
2769 %token NEXT
2770 %token NEXT_ITEM "NEXT-ITEM"
2771 %token NEXT_GROUP "NEXT GROUP"
2772 %token NEXT_PAGE "NEXT PAGE"
2773 %token NO
2774 %token NO_ADVANCING "NO ADVANCING"
2775 %token NO_AUTOSEL "NO-AUTOSEL"
2776 %token NO_AUTO_DEFAULT "NO-AUTO-DEFAULT"
2777 %token NO_BOX "NO-BOX"
2778 %token NO_DATA "NO DATA"
2779 %token NO_DIVIDERS "NO-DIVIDERS"
2780 %token NO_ECHO "NO-ECHO"
2781 %token NO_F4 "NO-F4"
2782 %token NO_FOCUS "NO-FOCUS"
2783 %token NO_GROUP_TAB "NO-GROUP-TAB"
2784 %token NO_KEY_LETTER "NO-KEY-LETTER"
2785 %token NOMINAL
2786 %token NO_SEARCH "NO-SEARCH"
2787 %token NO_UPDOWN "NO-UPDOWN"
2788 %token NONNUMERIC
2789 %token NORMAL
2790 %token NOT
2791 %token NOTAB
2792 %token NOTHING
2793 %token NOTIFY
2794 %token NOTIFY_CHANGE "NOTIFY-CHANGE"
2795 %token NOTIFY_DBLCLICK "NOTIFY-DBLCLICK"
2796 %token NOTIFY_SELCHANGE "NOTIFY-SELCHANGE"
2797 %token NOT_END "NOT END"
2798 %token NOT_EOP "NOT EOP"
2799 %token NOT_ESCAPE "NOT ESCAPE"
2800 %token NOT_EQUAL "NOT EQUAL"
2801 %token NOT_EXCEPTION "NOT EXCEPTION"
2802 %token NOT_INVALID_KEY "NOT INVALID KEY"
2803 %token NOT_OVERFLOW "NOT OVERFLOW"
2804 %token NOT_SIZE_ERROR "NOT SIZE ERROR"
2805 %token NUM_COL_HEADINGS "NUM-COL-HEADINGS"
2806 %token NUM_ROWS "NUM-ROWS"
2807 %token NUMBER
2808 %token NUMBERS
2809 %token NUMERIC
2810 %token NUMERIC_EDITED "NUMERIC-EDITED"
2811 %token NUMVALC_FUNC "FUNCTION NUMVAL-C"
2812 %token OBJECT
2813 %token OBJECT_COMPUTER "OBJECT-COMPUTER"
2814 %token OCCURS
2815 %token OF
2816 %token OFF
2817 %token OK_BUTTON "OK-BUTTON"
2818 %token OMITTED
2819 %token ON
2820 %token ONLY
2821 %token OPEN
2822 %token OPTIONAL
2823 %token OPTIONS
2824 %token OR
2825 %token ORDER
2826 %token ORGANIZATION
2827 %token OTHER
2828 %token OTHERS
2829 %token OUTPUT
2830 %token OVERLAP_LEFT "OVERLAP-LEFT"
2831 %token OVERLAP_TOP "OVERLAP-TOP"
2832 %token OVERLINE
2833 %token PACKED_DECIMAL "PACKED-DECIMAL"
2834 %token PADDING
2835 %token PASCAL
2836 %token PAGE
2837 %token PAGE_COUNTER "PAGE-COUNTER"
2838 %token PAGE_SETUP "PAGE-SETUP"
2839 %token PAGED
2840 %token PARAGRAPH
2841 %token PARENT
2842 %token PARSE
2843 %token PASSWORD
2844 %token PERFORM
2845 %token PERMANENT
2846 %token PH
2847 %token PF
2848 %token PHYSICAL
2849 %token PICTURE
2850 %token PICTURE_SYMBOL "PICTURE SYMBOL"
2851 %token PIXEL
2852 %token PLACEMENT
2853 %token PLUS
2854 %token POINTER
2855 %token POP_UP "POP-UP"
2856 %token POS
2857 %token POSITION
2858 %token POSITION_SHIFT "POSITION-SHIFT"
2859 %token POSITIVE
2860 %token PRESENT
2861 %token PREVIOUS
2862 %token PRINT
2863 %token PRINT_CONTROL "PRINT-CONTROL"
2864 %token PRINT_NO_PROMPT "PRINT-NO-PROMPT"
2865 %token PRINT_PREVIEW "PRINT-PREVIEW"
2866 %token PRINTER
2867 %token PRINTER_1 "PRINTER-1"
2868 %token PRINTING
2869 %token PRIORITY
2870 %token PROCEDURE
2871 %token PROCEDURES
2872 %token PROCEED
2873 %token PROCESSING
2874 %token PROGRAM
2875 %token PROGRAM_ID "PROGRAM-ID"
2876 %token PROGRAM_NAME "program name"
2877 %token PROGRAM_POINTER "PROGRAM-POINTER"
2878 %token PROGRESS
2879 %token PROHIBITED
2880 %token PROMPT
2881 %token PROPERTIES
2882 %token PROPERTY
2883 %token PROTECTED
2884 %token PURGE
2885 %token PUSH_BUTTON "PUSH-BUTTON"
2886 %token QUERY_INDEX "QUERY-INDEX"
2887 %token QUEUE
2888 %token QUOTE
2889 %token RADIO_BUTTON "RADIO-BUTTON"
2890 %token RAISE
2891 %token RAISED
2892 %token RANDOM
2893 %token RD
2894 %token READ
2895 %token READERS
2896 %token READ_ONLY "READ-ONLY"
2897 %token READY_TRACE "READY TRACE"
2898 %token RECEIVE
2899 %token RECORD
2900 %token RECORD_DATA "RECORD-DATA"
2901 %token RECORD_OVERFLOW "RECORD-OVERFLOW"
2902 %token RECORD_TO_ADD "RECORD-TO-ADD"
2903 %token RECORD_TO_DELETE "RECORD-TO-DELETE"
2904 %token RECORDING
2905 %token RECORDS
2906 %token RECURSIVE
2907 %token REDEFINES
2908 %token REEL
2909 %token REFERENCE
2910 %token REFERENCES
2911 %token REFRESH
2912 %token REGION_COLOR "REGION-COLOR"
2913 %token RELATIVE
2914 %token RELEASE
2915 %token REMAINDER
2916 %token REMOVAL
2917 %token RENAMES
2918 %token REORG_CRITERIA "REORG-CRITERIA"
2919 %token REPLACE
2920 %token REPLACING
2921 %token REPORT
2922 %token REPORTING
2923 %token REPORTS
2924 %token REPOSITORY
2925 %token REQUIRED
2926 %token REREAD
2927 %token RERUN
2928 %token RESERVE
2929 %token RESET
2930 %token RESET_TRACE "RESET TRACE"
2931 %token RESET_GRID "RESET-GRID"
2932 %token RESET_LIST "RESET-LIST"
2933 %token RESET_TABS "RESET-TABS"
2934 %token RETRY
2935 %token RETURN
2936 %token RETURNING
2937 %token REVERSE
2938 %token REVERSE_FUNC "FUNCTION REVERSE"
2939 %token REVERSE_VIDEO "REVERSE-VIDEO"
2940 %token REVERSED
2941 %token REWIND
2942 %token REWRITE
2943 %token RF
2944 %token RH
2945 %token RIGHT
2946 %token RIGHT_ALIGN "RIGHT-ALIGN"
2947 %token RIMMED
2948 %token ROLLBACK
2949 %token ROUNDED
2950 %token ROUNDING
2951 %token ROW_COLOR "ROW-COLOR"
2952 %token ROW_COLOR_PATTERN "ROW-COLOR-PATTERN"
2953 %token ROW_DIVIDERS "ROW-DIVIDERS"
2954 %token ROW_FONT "ROW-FONT"
2955 %token ROW_HEADINGS "ROW-HEADINGS"
2956 %token ROW_PROTECTION "ROW-PROTECTION"
2957 %token RUN
2958 %token S
2959 %token SAME
2960 %token SAVE_AS "SAVE-AS"
2961 %token SAVE_AS_NO_PROMPT "SAVE-AS-NO-PROMPT"
2962 %token SCREEN
2963 %token SCREEN_CONTROL "SCREEN CONTROL"
2964 %token SCROLL
2965 %token SCROLL_BAR "SCROLL-BAR"
2966 %token SD
2967 %token SEARCH
2968 %token SEARCH_OPTIONS "SEARCH-OPTIONS"
2969 %token SEARCH_TEXT "SEARCH-TEXT"
2970 %token SECONDS
2971 %token SECTION
2972 %token SECURE
2973 %token SEGMENT
2974 %token SEGMENT_LIMIT "SEGMENT-LIMIT"
2975 %token SELECT
2976 %token SELECTION_INDEX "SELECTION-INDEX"
2977 %token SELECTION_TEXT "SELECTION-TEXT"
2978 %token SELECT_ALL "SELECTION-ALL"
2979 %token SELF_ACT "SELF-ACT"
2980 %token SEMI_COLON "semi-colon"
2981 %token SEND
2982 %token SENTENCE
2983 %token SEPARATE
2984 %token SEPARATION
2985 %token SEQUENCE
2986 %token SEQUENTIAL
2987 %token SET
2988 %token SEVENTY_EIGHT "level-number 78"
2989 %token SHADING
2990 %token SHADOW
2991 %token SHARING
2992 %token SHORT_DATE "SHORT-DATE"
2993 %token SHOW_LINES "SHOW-LINES"
2994 %token SHOW_NONE "SHOW-NONE"
2995 %token SHOW_SEL_ALWAYS "SHOW-SEL-ALWAYS"
2996 %token SIGN
2997 %token SIGNED
2998 %token SIGNED_INT "SIGNED-INT"
2999 %token SIGNED_LONG "SIGNED-LONG"
3000 %token SIGNED_SHORT "SIGNED-SHORT"
3001 %token SIXTY_SIX "level-number 66"
3002 %token SIZE
3003 %token SIZE_ERROR "SIZE ERROR"
3004 %token SMALL_FONT "SMALL-FONT"
3005 %token SORT
3006 %token SORT_MERGE "SORT-MERGE"
3007 %token SORT_ORDER "SORT-ORDER"
3008 %token SOURCE
3009 %token SOURCE_COMPUTER "SOURCE-COMPUTER"
3010 %token SPACE
3011 %token SPECIAL_NAMES "SPECIAL-NAMES"
3012 %token SPINNER
3013 %token SQUARE
3014 %token STANDARD
3015 %token STANDARD_1 "STANDARD-1"
3016 %token STANDARD_2 "STANDARD-2"
3017 %token STANDARD_BINARY "STANDARD-BINARY"
3018 %token STANDARD_DECIMAL "STANDARD-DECIMAL"
3019 %token START
3020 %token START_X "START-X"
3021 %token START_Y "START-Y"
3022 %token STATIC
3023 %token STATIC_LIST "STATIC-LIST"
3024 %token STATUS
3025 %token STATUS_BAR "STATUS-BAR"
3026 %token STATUS_TEXT "STATUS-TEXT"
3027 %token STDCALL
3028 %token STEP
3029 %token STOP
3030 %token STRING
3031 %token STRONG
3032 %token STYLE
3033 %token SUB_QUEUE_1 "SUB-QUEUE-1"
3034 %token SUB_QUEUE_2 "SUB-QUEUE-2"
3035 %token SUB_QUEUE_3 "SUB-QUEUE-3"
3036 %token SUBSTITUTE_FUNC "FUNCTION SUBSTITUTE"
3037 %token SUBSTITUTE_CASE_FUNC "FUNCTION SUBSTITUTE-CASE"
3038 %token SUBTRACT
3039 %token SUBWINDOW
3040 %token SUM
3041 %token SUPPRESS
3042 %token SUPPRESS_XML "SUPPRESS"
3043 %token SYMBOLIC
3044 %token SYNCHRONIZED
3045 %token SYSTEM_DEFAULT "SYSTEM-DEFAULT"
3046 %token SYSTEM_INFO "SYSTEM-INFO"
3047 %token SYSTEM_OFFSET "SYSTEM-OFFSET"
3048 %token TAB
3049 %token TAB_TO_ADD "TAB-TO-ADD"
3050 %token TAB_TO_DELETE "TAB-TO-DELETE"
3051 %token TABLE
3052 %token TALLYING
3053 %token TEMPORARY
3054 %token TAPE
3055 %token TERMINAL
3056 %token TERMINATE
3057 %token TERMINAL_INFO "TERMINAL-INFO"
3058 %token TERMINATION_VALUE "TERMINATION-VALUE"
3059 %token TEST
3060 %token TEXT
3061 %token THAN
3062 %token THEN
3063 %token THREAD
3064 %token THREADS
3065 %token THRU
3066 %token THUMB_POSITION "THUMB-POSITION"
3067 %token TILED_HEADINGS "TILED-HEADINGS"
3068 %token TIME
3069 %token TIME_OUT "TIME-OUT"
3070 %token TIMES
3071 %token TITLE
3072 %token TITLE_POSITION "TITLE-POSITION"
3073 %token TO
3074 %token TOK_AMPER "&"
3075 %token TOK_CLOSE_PAREN ")"
3076 %token TOK_COLON ":"
3077 %token TOK_DIV "/"
3078 %token TOK_DOT "."
3079 %token TOK_EQUAL "="
3080 %token TOK_EXTERN "EXTERN"
3081 %token TOK_FALSE "FALSE"
3082 %token TOK_FILE "FILE"
3083 %token TOK_GREATER ">"
3084 %token TOK_INITIAL "INITIAL"
3085 %token TOK_LESS "<"
3086 %token TOK_MINUS "-"
3087 %token TOK_MUL "*"
3088 %token TOK_NULL "NULL"
3089 %token TOK_OVERFLOW "OVERFLOW"
3090 %token TOK_OPEN_PAREN "("
3091 %token TOK_PLUS "+"
3092 %token TOK_TRUE "TRUE"
3093 %token TOP
3094 %token TOWARD_GREATER "TOWARD-GREATER"
3095 %token TOWARD_LESSER "TOWARD-LESSER"
3096 %token TRACK
3097 %token TRACKS
3098 %token TRACK_AREA "TRACK-AREA"
3099 %token TRACK_LIMIT "TRACK-LIMIT"
3100 %token TRADITIONAL_FONT "TRADITIONAL-FONT"
3101 %token TRAILING
3102 %token TRAILING_SHIFT "TRAILING-SHIFT"
3103 %token TRANSFORM
3104 %token TRANSPARENT
3105 %token TREE_VIEW "TREE-VIEW"
3106 %token TRIM_FUNC "FUNCTION TRIM"
3107 %token TRUNCATION
3108 %token TYPE
3109 %token TYPEDEF
3110 %token U
3111 %token UCS_4 "UCS-4"
3112 %token UNBOUNDED
3113 %token UNDERLINE
3114 %token UNFRAMED
3115 %token UNIT
3116 %token UNLOCK
3117 %token UNSIGNED
3118 %token UNSIGNED_INT "UNSIGNED-INT"
3119 %token UNSIGNED_LONG "UNSIGNED-LONG"
3120 %token UNSIGNED_SHORT "UNSIGNED-SHORT"
3121 %token UNSORTED
3122 %token UNSTRING
3123 %token UNTIL
3124 %token UP
3125 %token UPDATE
3126 %token UPDATERS
3127 %token UPON
3128 %token UPON_ARGUMENT_NUMBER "UPON ARGUMENT-NUMBER"
3129 %token UPON_COMMAND_LINE "UPON COMMAND-LINE"
3130 %token UPON_ENVIRONMENT_NAME "UPON ENVIRONMENT-NAME"
3131 %token UPON_ENVIRONMENT_VALUE "UPON ENVIRONMENT-VALUE"
3132 %token UPPER
3133 %token UPPER_CASE_FUNC "FUNCTION UPPER-CASE"
3134 %token USAGE
3135 %token USE
3136 %token USE_ALT "USE-ALT"
3137 %token USE_RETURN "USE-RETURN"
3138 %token USE_TAB "USE-TAB"
3139 %token USER
3140 %token USER_DEFAULT "USER-DEFAULT"
3141 %token USER_FUNCTION_NAME "user function name"
3142 %token USING
3143 %token UTF_8 "UTF-8"
3144 %token UTF_16 "UTF-16"
3145 %token V
3146 %token VALIDATE
3147 %token VALIDATING
3148 %token VALUE
3149 %token VALUE_FORMAT "VALUE-FORMAT"
3150 %token VARIABLE
3151 %token VARIANT
3152 %token VARYING
3153 %token VERTICAL
3154 %token VERY_HEAVY "VERY-HEAVY"
3155 %token VIRTUAL_WIDTH "VIRTUAL-WIDTH"
3156 %token VOLATILE
3157 %token VPADDING
3158 %token VSCROLL
3159 %token VSCROLL_BAR "VSCROLL-BAR"
3160 %token VSCROLL_POS "VSCROLL-POS"
3161 %token VTOP
3162 %token WAIT
3163 %token WEB_BROWSER "WEB-BROWSER"
3164 %token WHEN
3165 %token WHEN_COMPILED_FUNC "FUNCTION WHEN-COMPILED"
3166 %token WHEN_XML "WHEN"
3167 %token WIDTH
3168 %token WIDTH_IN_CELLS "WIDTH-IN-CELLS"
3169 %token WINDOW
3170 %token WITH
3171 %token WORD "Identifier"
3172 %token WORDS
3173 %token WORKING_STORAGE "WORKING-STORAGE"
3174 %token WRAP
3175 %token WRITE
3176 %token WRITE_ONLY "WRITE-ONLY"
3177 %token WRITE_VERIFY "WRITE-VERIFY"
3178 %token WRITERS
3179 %token X
3180 %token XML
3181 %token XML_DECLARATION "XML-DECLARATION"
3182 %token Y
3183 %token YYYYDDD
3184 %token YYYYMMDD
3185 %token ZERO
3186
3187 /* Set up precedence operators to force shift */
3188
3189 %nonassoc SHIFT_PREFER
3190
3191 %nonassoc ELSE
3192
3193 %nonassoc ACCEPT
3194 %nonassoc ADD
3195 %nonassoc ALLOCATE
3196 %nonassoc ALTER
3197 %nonassoc CALL
3198 %nonassoc CANCEL
3199 %nonassoc CLOSE
3200 %nonassoc COMMIT
3201 %nonassoc COMPUTE
3202 %nonassoc CONTINUE
3203 %nonassoc DELETE
3204 %nonassoc DESTROY
3205 %nonassoc DISABLE
3206 %nonassoc DISPLAY
3207 %nonassoc DIVIDE
3208 %nonassoc ENABLE
3209 %nonassoc ENTRY
3210 %nonassoc EVALUATE
3211 %nonassoc EXHIBIT
3212 %nonassoc EXIT
3213 %nonassoc FREE
3214 %nonassoc GENERATE
3215 %nonassoc GO
3216 %nonassoc GOBACK
3217 %nonassoc IF
3218 %nonassoc INITIALIZE
3219 %nonassoc INITIATE
3220 %nonassoc INQUIRE
3221 %nonassoc INSPECT
3222 %nonassoc JSON
3223 %nonassoc MERGE
3224 %nonassoc MODIFY
3225 %nonassoc MOVE
3226 %nonassoc MULTIPLY
3227 %nonassoc NEXT
3228 %nonassoc OPEN
3229 %nonassoc PERFORM
3230 %nonassoc PURGE
3231 %nonassoc RAISE
3232 %nonassoc READ
3233 %nonassoc READY_TRACE
3234 %nonassoc RECEIVE
3235 %nonassoc RELEASE
3236 %nonassoc RESET_TRACE
3237 %nonassoc RETURN
3238 %nonassoc REWRITE
3239 %nonassoc ROLLBACK
3240 %nonassoc SEARCH
3241 %nonassoc SEND
3242 %nonassoc SET
3243 %nonassoc SORT
3244 %nonassoc START
3245 %nonassoc STOP
3246 %nonassoc STRING
3247 %nonassoc SUBTRACT
3248 %nonassoc SUPPRESS
3249 %nonassoc TERMINATE
3250 %nonassoc TRANSFORM
3251 %nonassoc UNLOCK
3252 %nonassoc UNSTRING
3253 %nonassoc VALIDATE
3254 %nonassoc WRITE
3255 %nonassoc XML
3256
3257 %nonassoc NOT_END END
3258 %nonassoc NOT_EOP EOP
3259 %nonassoc NOT_INVALID_KEY INVALID_KEY
3260 %nonassoc NOT_OVERFLOW TOK_OVERFLOW
3261 %nonassoc NOT_SIZE_ERROR SIZE_ERROR
3262 %nonassoc NOT_EXCEPTION EXCEPTION NOT_ESCAPE ESCAPE
3263 %nonassoc NO_DATA DATA
3264
3265 %nonassoc END_ACCEPT
3266 %nonassoc END_ADD
3267 %nonassoc END_CALL
3268 %nonassoc END_COMPUTE
3269 %nonassoc END_DELETE
3270 %nonassoc END_DISPLAY
3271 %nonassoc END_DIVIDE
3272 %nonassoc END_EVALUATE
3273 %nonassoc END_FUNCTION
3274 %nonassoc END_IF
3275 %nonassoc END_JSON
3276 %nonassoc END_MODIFY
3277 %nonassoc END_MULTIPLY
3278 %nonassoc END_PERFORM
3279 %nonassoc END_PROGRAM
3280 %nonassoc END_READ
3281 %nonassoc END_RECEIVE
3282 %nonassoc END_RETURN
3283 %nonassoc END_REWRITE
3284 %nonassoc END_SEARCH
3285 %nonassoc END_START
3286 %nonassoc END_STRING
3287 %nonassoc END_SUBTRACT
3288 %nonassoc END_UNSTRING
3289 %nonassoc END_WRITE
3290 %nonassoc END_XML
3291
3292 %nonassoc PROGRAM_ID
3293 %nonassoc WHEN
3294 %nonassoc IN
3295
3296 %nonassoc WORD
3297 %nonassoc LITERAL
3298
3299 %nonassoc TOK_OPEN_PAREN
3300 %nonassoc TOK_PLUS
3301 %nonassoc TOK_MINUS
3302 %nonassoc TOK_DOT
3303
3304 %nonassoc error
3305
3306 %%
3307
3308 /* COBOL Compilation Unit */
3309
3310 start:
3311 {
3312 clear_initial_values ();
3313 current_program = NULL;
3314 defined_prog_list = NULL;
3315 cobc_cs_check = 0;
3316 main_flag_set = 0;
3317 current_program = cb_build_program (NULL, 0);
3318 cb_set_intr_when_compiled ();
3319 cb_build_registers ();
3320 cb_add_external_defined_registers ();
3321 }
3322 compilation_group
3323 {
3324 if (!current_program->flag_validated) {
3325 current_program->flag_validated = 1;
3326 cb_validate_program_body (current_program);
3327 }
3328 if (depth > 1) {
3329 cb_error (_("multiple PROGRAM-ID's without matching END PROGRAM"));
3330 }
3331 if (cobc_flag_main && !main_flag_set) {
3332 cb_error (_("executable requested but no program found"));
3333 }
3334 if (errorcount > 0) {
3335 YYABORT;
3336 }
3337 if (!current_program->entry_list) {
3338 backup_current_pos ();
3339 emit_entry (current_program->program_id, 0, NULL, NULL);
3340 }
3341 }
3342 ;
3343
3344 compilation_group:
3345 simple_prog /* extension: single program without PROCEDURE DIVISION */
3346 | nested_list
3347 ;
3348
3349 nested_list:
3350 {
3351 first_prog = 1;
3352 depth = 0;
3353 setup_from_identification = 0;
3354 }
3355 source_element_list
3356 ;
3357
3358 source_element_list:
3359 source_element
3360 | source_element_list source_element
3361 ;
3362
3363 source_element:
3364 program_definition
3365 | function_definition
3366 ;
3367
3368 simple_prog:
3369 {
3370 program_init_without_program_id ();
3371 }
3372 _program_body
3373 /* do cleanup */
3374 {
3375 backup_current_pos ();
3376 clean_up_program (NULL, COB_MODULE_TYPE_PROGRAM);
3377 }
3378 ;
3379
3380 program_definition:
3381 _identification_header
3382 program_id_paragraph
3383 _program_body
3384 _end_program_list
3385 /*
3386 The _end_program_list above is used for allowing an end marker
3387 in a program which contains a nested program.
3388 */
3389 ;
3390
3391 function_definition:
3392 _identification_header
3393 function_id_paragraph
3394 _program_body
3395 end_function
3396 ;
3397
3398 _end_program_list:
3399 /* empty (still do cleanup) */
3400 {
3401 backup_current_pos ();
3402 clean_up_program (NULL, COB_MODULE_TYPE_PROGRAM);
3403 }
3404 | end_program_list
3405 ;
3406
3407 end_program_list:
3408 end_program
3409 | end_program_list end_program
3410 ;
3411
3412 end_program:
3413 END_PROGRAM
3414 {
3415 backup_current_pos ();
3416 }
3417 end_program_name TOK_DOT
3418 {
3419 first_nested_program = 0;
3420 clean_up_program ($3, COB_MODULE_TYPE_PROGRAM);
3421 }
3422 ;
3423
3424 end_function:
3425 END_FUNCTION
3426 {
3427 backup_current_pos ();
3428 }
3429 end_program_name TOK_DOT
3430 {
3431 clean_up_program ($3, COB_MODULE_TYPE_FUNCTION);
3432 }
3433 ;
3434
3435 /* PROGRAM body */
3436
3437 _program_body:
3438 _options_paragraph
3439 _environment_division
3440 {
3441 cb_validate_program_environment (current_program);
3442 }
3443 _data_division
3444 {
3445 /* note:
3446 we also validate all references we found so far here */
3447 cb_validate_program_data (current_program);
3448 within_typedef_definition = 0;
3449 }
3450 _procedure_division
3451 ;
3452
3453 /* IDENTIFICATION DIVISION */
3454
3455 _identification_header:
3456 %prec SHIFT_PREFER
3457 | identification_header
3458 ;
3459
3460 identification_header:
3461 identification_or_id DIVISION TOK_DOT
3462 {
3463 setup_program_start ();
3464 setup_from_identification = 1;
3465 }
3466 ;
3467
3468
3469 identification_or_id:
3470 IDENTIFICATION | ID
3471 ;
3472
3473 program_id_paragraph:
3474 PROGRAM_ID
3475 {
3476 cobc_in_id = 1;
3477 }
3478 TOK_DOT program_id_name _as_literal
3479 {
3480 if (setup_program ($4, $5, COB_MODULE_TYPE_PROGRAM)) {
3481 YYABORT;
3482 }
3483
3484 setup_prototype ($4, $5, COB_MODULE_TYPE_PROGRAM, 1);
3485 }
3486 _program_type TOK_DOT
3487 {
3488 cobc_cs_check = 0;
3489 cobc_in_id = 0;
3490 }
3491 ;
3492
3493 function_id_paragraph:
3494 FUNCTION_ID
3495 {
3496 cobc_in_id = 1;
3497 }
3498 TOK_DOT program_id_name _as_literal TOK_DOT
3499 {
3500 if (setup_program ($4, $5, COB_MODULE_TYPE_FUNCTION)) {
3501 YYABORT;
3502 }
3503 setup_prototype ($4, $5, COB_MODULE_TYPE_FUNCTION, 1);
3504 cobc_cs_check = 0;
3505 cobc_in_id = 0;
3506 }
3507 ;
3508
3509 program_id_name:
3510 PROGRAM_NAME
3511 {
3512 if (CB_REFERENCE_P ($1) && CB_WORD_COUNT ($1) > 0) {
3513 redefinition_error ($1);
3514 }
3515 /*
3516 The program name is a key part of defining the current_program, so we
3517 mustn't lose it (unlike in undefined_word).
3518 */
3519 $$ = $1;
3520 }
3521 | LITERAL
3522 {
3523 cb_trim_program_id ($1);
3524 }
3525 ;
3526
3527 end_program_name:
3528 PROGRAM_NAME
3529 | LITERAL
3530 {
3531 cb_trim_program_id ($1);
3532 }
3533 ;
3534
3535 _as_literal:
3536 /* empty */ { $$ = NULL; }
3537 | AS LITERAL { $$ = $2; }
3538 ;
3539
3540 _program_type:
3541 | _is program_type_clause _program
3542 ;
3543
3544 program_type_clause:
3545 COMMON
3546 {
3547 if (!current_program->nested_level) {
3548 cb_error (_("COMMON may only be used in a contained program"));
3549 } else {
3550 current_program->flag_common = 1;
3551 cb_add_common_prog (current_program);
3552 }
3553 }
3554 | init_or_recurse_and_common
3555 {
3556 if (!current_program->nested_level) {
3557 cb_error (_("COMMON may only be used in a contained program"));
3558 } else {
3559 current_program->flag_common = 1;
3560 cb_add_common_prog (current_program);
3561 }
3562 }
3563 | init_or_recurse
3564 | EXTERNAL
3565 {
3566 CB_PENDING (_("CALL prototypes"));
3567 }
3568 ;
3569
3570 init_or_recurse_and_common:
3571 init_or_recurse COMMON
3572 | COMMON init_or_recurse
3573 ;
3574
3575 init_or_recurse:
3576 TOK_INITIAL
3577 {
3578 current_program->flag_initial = 1;
3579 }
3580 | RECURSIVE
3581 {
3582 current_program->flag_recursive = 1;
3583 }
3584 ;
3585
3586 _options_paragraph:
3587 /* empty */
3588 | OPTIONS TOK_DOT
3589 _options_clauses
3590 {
3591 cobc_cs_check = 0;
3592 }
3593 ;
3594
3595 _options_clauses:
3596 _arithmetic_clause
3597 _default_rounded_clause
3598 _entry_convention_clause
3599 _intermediate_rounding_clause
3600 TOK_DOT
3601 ;
3602
3603 _arithmetic_clause:
3604 /* empty */
3605 | ARITHMETIC _is arithmetic_choice
3606 ;
3607
3608 arithmetic_choice:
3609 NATIVE
3610 {
3611 /* FIXME: the IBM-compatible ARITHMETIC should only be disabled
3612 for the specified program (and its nested programs)
3613 note: ibm-strict.conf has no OPTIONS paragraph, but ibm.conf does */
3614 cb_arithmetic_osvs = 0;
3615 }
3616 | STANDARD
3617 {
3618 CB_PENDING ("STANDARD ARITHMETIC");
3619 }
3620 | STANDARD_BINARY
3621 {
3622 CB_PENDING ("STANDARD-BINARY ARITHMETIC");
3623 }
3624 | STANDARD_DECIMAL
3625 {
3626 CB_PENDING ("STANDARD-DECIMAL ARITHMETIC");
3627 }
3628 /* note: the IBM-compatible ARITHMETIC should likely get in here as an extension
3629 but only for the specified program (and its nested programs)
3630 decide for a good token name (with CB_CS_OPTIONS), once published it will be fixed
3631 | OSVS
3632 {
3633 cb_arithmetic_osvs = 1;
3634 }
3635 */
3636 ;
3637
3638 _default_rounded_clause:
3639 /* empty */
3640 {
3641 default_rounded_mode = cb_int (COB_STORE_ROUND);
3642 }
3643 | DEFAULT ROUNDED _mode _is round_choice
3644 {
3645 if ($5) {
3646 default_rounded_mode = $5;
3647 } else {
3648 default_rounded_mode = cb_int (COB_STORE_ROUND);
3649 }
3650 }
3651 ;
3652
3653 _entry_convention_clause:
3654 /* empty */
3655 | ENTRY_CONVENTION _is convention_type
3656 {
3657 current_program->entry_convention = $3;
3658 }
3659 ;
3660
3661 convention_type:
3662 COBOL
3663 {
3664 $$ = cb_int (CB_CONV_COBOL);
3665 }
3666 | TOK_EXTERN
3667 {
3668 $$ = cb_int0;
3669 }
3670 | STDCALL
3671 {
3672 $$ = cb_int (CB_CONV_STDCALL);
3673 }
3674 ;
3675
3676 _intermediate_rounding_clause:
3677 /* empty */
3678 | INTERMEDIATE ROUNDING _is intermediate_rounding_choice
3679 {
3680 CB_PENDING ("INTERMEDIATE ROUNDING");
3681 }
3682 ;
3683
3684 intermediate_rounding_choice:
3685 NEAREST_AWAY_FROM_ZERO
3686 {
3687 $$ = cb_int (COB_STORE_ROUND | COB_STORE_NEAR_AWAY_FROM_ZERO);
3688 }
3689 | NEAREST_EVEN
3690 {
3691 $$ = cb_int (COB_STORE_ROUND | COB_STORE_NEAR_EVEN);
3692 }
3693 | PROHIBITED
3694 {
3695 $$ = cb_int (COB_STORE_ROUND | COB_STORE_PROHIBITED);
3696 }
3697 | TRUNCATION
3698 {
3699 $$ = cb_int (COB_STORE_ROUND | COB_STORE_TRUNCATION);
3700 }
3701 ;
3702
3703 /* ENVIRONMENT DIVISION */
3704
3705 _environment_division:
3706 _environment_header
3707 _configuration_section
3708 _input_output_section
3709 ;
3710
3711 _environment_header:
3712 | ENVIRONMENT DIVISION TOK_DOT
3713 {
3714 header_check |= COBC_HD_ENVIRONMENT_DIVISION;
3715 }
3716 ;
3717
3718 /* CONFIGURATION SECTION */
3719
3720 _configuration_section:
3721 _configuration_header
3722 _configuration_paragraphs
3723 ;
3724
3725 _configuration_header:
3726 | CONFIGURATION SECTION TOK_DOT
3727 {
3728 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION, 0, 0, 0);
3729 header_check |= COBC_HD_CONFIGURATION_SECTION;
3730 if (current_program->nested_level) {
3731 cb_error (_("%s not allowed in nested programs"), "CONFIGURATION SECTION");
3732 }
3733 }
3734 ;
3735
3736 _configuration_paragraphs:
3737 /* empty */
3738 | configuration_paragraphs
3739 ;
3740
3741 configuration_paragraphs:
3742 configuration_paragraph
3743 | configuration_paragraphs configuration_paragraph
3744 ;
3745
3746 configuration_paragraph:
3747 source_computer_paragraph
3748 | object_computer_paragraph
3749 | special_names_header
3750 | special_names_sentence
3751 | repository_paragraph
3752 ;
3753
3754 /* SOURCE-COMPUTER paragraph */
3755
3756 source_computer_paragraph:
3757 SOURCE_COMPUTER TOK_DOT
3758 {
3759 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
3760 COBC_HD_CONFIGURATION_SECTION, 0, 0);
3761 check_conf_section_order (COBC_HD_SOURCE_COMPUTER);
3762 set_conf_section_part (COBC_HD_SOURCE_COMPUTER);
3763 }
3764 _source_computer_entry
3765 ;
3766
3767 _source_computer_entry:
3768 %prec SHIFT_PREFER
3769 | computer_words _with_debugging_mode TOK_DOT
3770 ;
3771
3772 _with_debugging_mode:
3773 | _with DEBUGGING MODE
3774 {
3775 current_program->flag_debugging = 1;
3776 needs_debug_item = 1;
3777 cobc_cs_check = 0;
3778 cb_build_debug_item ();
3779 }
3780 ;
3781
3782 /* OBJECT-COMPUTER paragraph */
3783
3784 object_computer_paragraph:
3785 OBJECT_COMPUTER TOK_DOT
3786 {
3787 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
3788 COBC_HD_CONFIGURATION_SECTION, 0, 0);
3789 check_conf_section_order (COBC_HD_OBJECT_COMPUTER);
3790 set_conf_section_part (COBC_HD_OBJECT_COMPUTER);
3791 }
3792 _object_computer_entry
3793 {
3794 cobc_cs_check = 0;
3795 }
3796 ;
3797
3798 _object_computer_entry:
3799 %prec SHIFT_PREFER
3800 | computer_words TOK_DOT
3801 | computer_words object_clauses_list TOK_DOT
3802 | object_clauses_list TOK_DOT
3803 ;
3804
3805 object_clauses_list:
3806 object_clauses
3807 | object_clauses_list object_clauses
3808 ;
3809
3810 object_clauses:
3811 object_computer_memory
3812 | object_computer_sequence
3813 | object_computer_segment
3814 | object_computer_class
3815 ;
3816
3817 object_computer_memory:
3818 MEMORY _size _is integer object_char_or_word_or_modules
3819 {
3820 cb_verify (cb_memory_size_clause, "MEMORY SIZE");
3821 }
3822 /* Ignore */
3823 ;
3824
3825 object_computer_sequence:
3826 _program program_collating_sequence
3827 {
3828 current_program->collating_sequence = alphanumeric_collation;
3829 current_program->collating_sequence_n = national_collation;
3830 }
3831 ;
3832
3833 program_collating_sequence:
3834 _collating SEQUENCE
3835 {
3836 alphanumeric_collation = national_collation = NULL;
3837 }
3838 program_coll_sequence_values
3839 ;
3840
3841 program_coll_sequence_values:
3842 _is single_reference
3843 {
3844 alphanumeric_collation = $2;
3845 }
3846 | _is single_reference single_reference
3847 {
3848 alphanumeric_collation = $2;
3849 CB_PENDING_X ($3, "NATIONAL COLLATING SEQUENCE");
3850 national_collation = $3;
3851 }
3852 | _for ALPHANUMERIC _is single_reference
3853 {
3854 alphanumeric_collation = $4;
3855 }
3856 | _for NATIONAL _is single_reference
3857 {
3858 CB_PENDING_X ($4, "NATIONAL COLLATING SEQUENCE");
3859 national_collation = $4;
3860 }
3861 | _for ALPHANUMERIC _is single_reference
3862 _for NATIONAL _is single_reference
3863 {
3864 alphanumeric_collation = $4;
3865 CB_PENDING_X ($8, "NATIONAL COLLATING SEQUENCE");
3866 national_collation = $8;
3867 }
3868 | _for NATIONAL _is single_reference
3869 _for ALPHANUMERIC _is single_reference
3870 {
3871 CB_PENDING_X ($4, "NATIONAL COLLATING SEQUENCE");
3872 national_collation = $4;
3873 alphanumeric_collation = $8;
3874 }
3875 ;
3876
3877 object_computer_segment:
3878 SEGMENT_LIMIT _is integer
3879 {
3880 if (cb_verify (cb_section_segments, "SEGMENT LIMIT")) {
3881 int segnum = cb_get_int ($3);
3882 if (segnum == 0 || segnum > 49) {
3883 cb_error (_("segment-number must be in range of values 1 to 49"));
3884 $$ = NULL;
3885 }
3886 }
3887 /* Ignore */
3888 }
3889 ;
3890
3891 object_computer_class:
3892 _character CLASSIFICATION _is locale_class
3893 {
3894 if (current_program->classification) {
3895 cb_error (_("duplicate CLASSIFICATION clause"));
3896 } else {
3897 current_program->classification = $4;
3898 }
3899 }
3900 ;
3901
3902 locale_class:
3903 single_reference
3904 {
3905 $$ = $1;
3906 }
3907 | LOCALE
3908 {
3909 $$ = NULL;
3910 }
3911 | USER_DEFAULT
3912 {
3913 $$ = cb_int1;
3914 }
3915 | SYSTEM_DEFAULT
3916 {
3917 $$ = cb_int1;
3918 }
3919 ;
3920
3921 computer_words:
3922 WORD
3923 | computer_words WORD
3924 ;
3925
3926 /* REPOSITORY paragraph */
3927
3928 repository_paragraph:
3929 REPOSITORY TOK_DOT
3930 {
3931 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
3932 COBC_HD_CONFIGURATION_SECTION, 0, 0);
3933 check_conf_section_order (COBC_HD_REPOSITORY);
3934 set_conf_section_part (COBC_HD_REPOSITORY);
3935 }
3936 _repository_entry
3937 {
3938 cobc_in_repository = 0;
3939 }
3940 ;
3941
3942 _repository_entry:
3943 /* empty */
3944 | repository_list TOK_DOT
3945 | repository_list error TOK_DOT
3946 {
3947 yyerrok;
3948 }
3949 ;
3950
3951 repository_list:
3952 repository_name
3953 | repository_list repository_name
3954 ;
3955
3956 repository_name:
3957 FUNCTION ALL INTRINSIC
3958 {
3959 functions_are_all = 1;
3960 }
3961 | FUNCTION WORD _as_literal
3962 {
3963 if ($2 != cb_error_node) {
3964 setup_prototype ($2, $3, COB_MODULE_TYPE_FUNCTION, 0);
3965 }
3966 }
3967 | FUNCTION repository_name_list INTRINSIC
3968 | PROGRAM WORD _as_literal
3969 {
3970 if ($2 != cb_error_node
3971 && cb_verify (cb_program_prototypes, _("PROGRAM phrase"))) {
3972 setup_prototype ($2, $3, COB_MODULE_TYPE_PROGRAM, 0);
3973 }
3974 }
3975 | FUNCTION repository_name_list error
3976 {
3977 yyerrok;
3978 }
3979 ;
3980
3981 repository_name_list:
3982 FUNCTION_NAME
3983 {
3984 current_program->function_spec_list =
3985 cb_list_add (current_program->function_spec_list, $1);
3986 }
3987 | repository_name_list FUNCTION_NAME
3988 {
3989 current_program->function_spec_list =
3990 cb_list_add (current_program->function_spec_list, $2);
3991 }
3992 ;
3993
3994
3995 /* SPECIAL-NAMES paragraph */
3996
3997 special_names_header:
3998 SPECIAL_NAMES TOK_DOT
3999 {
4000 check_duplicate = 0;
4001 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4002 COBC_HD_CONFIGURATION_SECTION, 0, 0);
4003 check_conf_section_order (COBC_HD_SPECIAL_NAMES);
4004 set_conf_section_part (COBC_HD_SPECIAL_NAMES);
4005 if (current_program->nested_level) {
4006 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4007 }
4008 }
4009 ;
4010
4011 special_names_sentence:
4012 special_name_list TOK_DOT
4013
4014 special_name_list:
4015 special_name
4016 | special_name_list special_name
4017 | /* FIXME: the error recovery is broken here, error token
4018 should be moved to "special_name" instead */
4019 special_name_list error
4020 ;
4021
4022 special_name:
4023 mnemonic_name_clause
4024 | alphabet_name_clause
4025 | symbolic_characters_clause
4026 | symbolic_constant_clause
4027 | locale_clause
4028 | class_name_clause
4029 | currency_sign_clause
4030 | decimal_point_clause
4031 | numeric_sign_clause
4032 | cursor_clause
4033 | crt_status_clause
4034 | screen_control
4035 | event_status
4036 | top_clause
4037 ;
4038
4039
4040 /* Mnemonic name clause */
4041
4042 mnemonic_name_clause:
4043 WORD
4044 {
4045 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4046 COBC_HD_CONFIGURATION_SECTION,
4047 COBC_HD_SPECIAL_NAMES, 0);
4048 check_duplicate = 0;
4049 if (current_program->nested_level) {
4050 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4051 save_tree = NULL;
4052 } else {
4053 /* lookup system name with special translation
4054 note: result in NULL + raised error if not found */
4055 save_tree = get_system_name_translated ($1);
4056 }
4057 }
4058 mnemonic_choices
4059 ;
4060
4061 mnemonic_choices:
4062 _is CRT
4063 {
4064 if (save_tree) {
4065 if (CB_SYSTEM_NAME(save_tree)->token != CB_DEVICE_CONSOLE) {
4066 cb_error_x (save_tree, _("invalid %s clause"), "");
4067 } else {
4068 current_program->flag_console_is_crt = 1;
4069 }
4070 }
4071 }
4072 /* CALL-CONVENTION n is ... */
4073 | integer _is undefined_word
4074 {
4075 if (save_tree) {
4076 if (CB_SYSTEM_NAME(save_tree)->token != CB_FEATURE_CONVENTION) {
4077 cb_error_x (save_tree, _("invalid %s clause"), "SPECIAL NAMES");
4078 } else if (CB_VALID_TREE ($3)) {
4079 CB_SYSTEM_NAME(save_tree)->value = $1;
4080 cb_define ($3, save_tree);
4081 CB_CHAIN_PAIR (current_program->mnemonic_spec_list,
4082 $3, save_tree);
4083 /* remove non-standard context-sensitive words when identical to mnemonic */
4084 if (strcasecmp (CB_NAME($3), "EXTERN" ) == 0 ||
4085 strcasecmp (CB_NAME($3), "STDCALL") == 0 ||
4086 strcasecmp (CB_NAME($3), "STATIC" ) == 0 ||
4087 strcasecmp (CB_NAME($3), "C" ) == 0 ||
4088 strcasecmp (CB_NAME($3), "PASCAL" ) == 0) {
4089 remove_context_sensitivity (CB_NAME($3), CB_CS_CALL);
4090 }
4091 }
4092 }
4093 }
4094 | _is undefined_word _special_name_mnemonic_on_off
4095 {
4096 if (save_tree && CB_VALID_TREE ($2)) {
4097 cb_define ($2, save_tree);
4098 CB_CHAIN_PAIR (current_program->mnemonic_spec_list,
4099 $2, save_tree);
4100 }
4101 }
4102 | on_off_clauses
4103 ;
4104
4105 _special_name_mnemonic_on_off:
4106 | on_off_clauses
4107 ;
4108
4109 on_off_clauses:
4110 on_off_clauses_1
4111 {
4112 check_on_off_duplicate = 0;
4113 }
4114 ;
4115
4116 on_off_clauses_1:
4117 on_or_off _onoff_status undefined_word
4118 {
4119 cb_tree x;
4120
4121 /* cb_define_switch_name checks param validity */
4122 x = cb_define_switch_name ($3, save_tree, $1 == cb_int1);
4123 if (x) {
4124 if ($1 == cb_int1) {
4125 check_repeated ("ON", SYN_CLAUSE_1, &check_on_off_duplicate);
4126 } else {
4127 check_repeated ("OFF", SYN_CLAUSE_2, &check_on_off_duplicate);
4128 }
4129 CB_CHAIN_PAIR (current_program->mnemonic_spec_list, $3, x);
4130 }
4131 }
4132 | on_off_clauses_1 on_or_off _onoff_status undefined_word
4133 {
4134 cb_tree x;
4135
4136 /* cb_define_switch_name checks param validity */
4137 x = cb_define_switch_name ($4, save_tree, $2 == cb_int1);
4138 if (x) {
4139 if ($2 == cb_int1) {
4140 check_repeated ("ON", SYN_CLAUSE_1, &check_on_off_duplicate);
4141 } else {
4142 check_repeated ("OFF", SYN_CLAUSE_2, &check_on_off_duplicate);
4143 }
4144 CB_CHAIN_PAIR (current_program->mnemonic_spec_list, $4, x);
4145 }
4146 }
4147 ;
4148
4149 /* ALPHABET clause */
4150
4151 alphabet_name_clause:
4152 ALPHABET undefined_word
4153 {
4154 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4155 COBC_HD_CONFIGURATION_SECTION,
4156 COBC_HD_SPECIAL_NAMES, 0);
4157 if (current_program->nested_level) {
4158 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4159 $$ = NULL;
4160 } else {
4161 /* Returns null on error */
4162 $$ = cb_build_alphabet_name ($2);
4163 }
4164 }
4165 alphabet_definition
4166 {
4167 if ($3) {
4168 current_program->alphabet_name_list =
4169 cb_list_add (current_program->alphabet_name_list, $3);
4170 }
4171 cobc_cs_check = 0;
4172 }
4173 ;
4174
4175 alphabet_definition:
4176 alphabet_target_alphanumeric
4177 {
4178 $$ = $0;
4179 if ($0) {
4180 CB_ALPHABET_NAME ($0)->alphabet_target = CB_ALPHABET_ALPHANUMERIC;
4181 }
4182 }
4183 _is alphabet_type_alphanumeric
4184 | alphabet_target_national
4185 {
4186 $$ = $0;
4187 if ($0) {
4188 CB_ALPHABET_NAME($0)->alphabet_target = CB_ALPHABET_NATIONAL;
4189 }
4190 }
4191 _is alphabet_type_national
4192 ;
4193
4194 alphabet_target_alphanumeric:
4195 /* empty */
4196 | _for ALPHANUMERIC
4197 ;
4198
4199 alphabet_target_national:
4200 _for NATIONAL
4201 ;
4202
4203 alphabet_type_alphanumeric:
4204 alphabet_type_common
4205 | STANDARD_1
4206 {
4207 if ($-1) {
4208 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_ASCII;
4209 }
4210 }
4211 | STANDARD_2
4212 {
4213 if ($-1) {
4214 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_ASCII;
4215 }
4216 }
4217 | EBCDIC /* concerning the standard: a code-name */
4218 {
4219 if ($-1) {
4220 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_EBCDIC;
4221 }
4222 }
4223 | ASCII /* concerning the standard: a code-name */
4224 {
4225 if ($-1) {
4226 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_ASCII;
4227 }
4228 }
4229 ;
4230
4231 alphabet_type_national:
4232 alphabet_type_common
4233 | UCS_4
4234 {
4235 if ($-1) {
4236 CB_PENDING_X ($-1, "ALPHABET UCS-4");
4237 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_UCS_4;
4238 }
4239 }
4240 | UTF_8
4241 {
4242 if ($-1) {
4243 CB_PENDING_X ($-1, "ALPHABET UTF-8");
4244 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_UTF_8;
4245 }
4246 }
4247 | UTF_16
4248 {
4249 if ($-1) {
4250 CB_PENDING_X ($-1, "ALPHABET UTF-16");
4251 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_UTF_16;
4252 }
4253 }
4254 ;
4255
4256 alphabet_type_common:
4257 NATIVE
4258 {
4259 if ($-1) {
4260 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_NATIVE;
4261 }
4262 }
4263 | LOCALE single_reference
4264 {
4265 if ($-1) {
4266 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_LOCALE;
4267 CB_ALPHABET_NAME ($-1)->custom_list = $2;
4268 CB_PENDING_X ($-1, "LOCALE ALPHABET");
4269 }
4270 }
4271 | alphabet_literal_list
4272 {
4273 if ($-1) {
4274 CB_ALPHABET_NAME ($-1)->alphabet_type = CB_ALPHABET_CUSTOM;
4275 CB_ALPHABET_NAME ($-1)->custom_list = $1;
4276 }
4277 }
4278 ;
4279
4280 alphabet_literal_list:
4281 alphabet_literal
4282 {
4283 $$ = CB_LIST_INIT ($1);
4284 }
4285 | alphabet_literal_list alphabet_literal
4286 {
4287 $$ = cb_list_add ($1, $2);
4288 }
4289 ;
4290
4291 alphabet_literal:
4292 alphabet_lits
4293 {
4294 $$ = $1;
4295 }
4296 | alphabet_lits THRU alphabet_lits
4297 {
4298 $$ = CB_BUILD_PAIR ($1, $3);
4299 }
4300 | alphabet_lits ALSO
4301 {
4302 $$ = CB_LIST_INIT ($1);
4303 }
4304 alphabet_also_sequence
4305 {
4306 $$ = $3;
4307 }
4308 ;
4309
4310 alphabet_also_sequence:
4311 alphabet_lits
4312 {
4313 cb_list_add ($0, $1);
4314 }
4315 | alphabet_also_sequence ALSO alphabet_lits
4316 {
4317 cb_list_add ($0, $3);
4318 }
4319 ;
4320
4321 alphabet_lits:
4322 LITERAL { $$ = $1; }
4323 | SPACE { $$ = cb_space; }
4324 | ZERO { $$ = cb_zero; }
4325 | QUOTE { $$ = cb_quote; }
4326 | HIGH_VALUE { $$ = cb_norm_high; }
4327 | LOW_VALUE { $$ = cb_norm_low; }
4328 ;
4329
4330 space_or_zero:
4331 SPACE { $$ = cb_space; }
4332 | ZERO { $$ = cb_zero; }
4333 ;
4334
4335
4336 /* SYMBOLIC characters clause */
4337
4338 symbolic_characters_clause:
4339 symbolic_collection _sym_in_word
4340 {
4341 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4342 COBC_HD_CONFIGURATION_SECTION,
4343 COBC_HD_SPECIAL_NAMES, 0);
4344 if (current_program->nested_level) {
4345 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4346 } else if ($1) {
4347 CB_CHAIN_PAIR (current_program->symbolic_char_list, $1, $2);
4348 }
4349 }
4350 ;
4351
4352 _sym_in_word:
4353 /* empty */
4354 {
4355 $$ = NULL;
4356 }
4357 | IN WORD
4358 {
4359 $$ = $2;
4360 }
4361 ;
4362
4363 symbolic_collection:
4364 %prec SHIFT_PREFER
4365 SYMBOLIC _characters symbolic_chars_list
4366 {
4367 $$ = $3;
4368 }
4369 ;
4370
4371 symbolic_chars_list:
4372 symbolic_chars_phrase
4373 {
4374 $$ = $1;
4375 }
4376 | symbolic_chars_list symbolic_chars_phrase
4377 {
4378 if ($2) {
4379 $$ = cb_list_append ($1, $2);
4380 } else {
4381 $$ = $1;
4382 }
4383 }
4384 ;
4385
4386 symbolic_chars_phrase:
4387 char_list _is_are integer_list
4388 {
4389 cb_tree l1;
4390 cb_tree l2;
4391
4392 if (cb_list_length ($1) != cb_list_length ($3)) {
4393 cb_error (_("invalid %s clause"), "SYMBOLIC");
4394 $$ = NULL;
4395 } else {
4396 l1 = $1;
4397 l2 = $3;
4398 for (; l1; l1 = CB_CHAIN (l1), l2 = CB_CHAIN (l2)) {
4399 CB_PURPOSE (l1) = CB_VALUE (l2);
4400 }
4401 $$ = $1;
4402 }
4403 }
4404 ;
4405
4406 char_list:
4407 unique_word
4408 {
4409 if ($1 == NULL) {
4410 $$ = NULL;
4411 } else {
4412 $$ = CB_LIST_INIT ($1);
4413 }
4414 }
4415 | char_list unique_word
4416 {
4417 if ($2 == NULL) {
4418 $$ = $1;
4419 } else {
4420 $$ = cb_list_add ($1, $2);
4421 }
4422 }
4423 ;
4424
4425 integer_list:
4426 symbolic_integer { $$ = CB_LIST_INIT ($1); }
4427 | integer_list symbolic_integer { $$ = cb_list_add ($1, $2); }
4428 ;
4429
4430
4431 /* SYMBOLIC constant clause */
4432
4433 symbolic_constant_clause:
4434 %prec SHIFT_PREFER
4435 SYMBOLIC CONSTANT symbolic_constant_list
4436 {
4437 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4438 COBC_HD_CONFIGURATION_SECTION,
4439 COBC_HD_SPECIAL_NAMES, 0);
4440 if (current_program->nested_level) {
4441 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4442 }
4443 (void)cb_verify (cb_symbolic_constant, "SYMBOLIC CONSTANT");
4444 }
4445 ;
4446
4447 symbolic_constant_list:
4448 symbolic_constant
4449 | symbolic_constant_list symbolic_constant
4450 ;
4451
4452 symbolic_constant:
4453 user_entry_name _is literal
4454 {
4455 struct cb_field *f;
4456 cb_tree v;
4457
4458 v = CB_LIST_INIT ($3);
4459 f = CB_FIELD (cb_build_constant ($1, v));
4460 f->flag_item_78 = 1;
4461 f->flag_constant = 1;
4462 f->flag_is_global = 1;
4463 f->level = 1;
4464 f->values = v;
4465 cb_needs_01 = 1;
4466 /* Ignore return value */
4467 (void)cb_validate_78_item (f, 0);
4468 }
4469 ;
4470
4471 /* CLASS clause */
4472
4473 class_name_clause:
4474 CLASS undefined_word _class_type _is class_item_list _in_alphabet
4475 {
4476 cb_tree x;
4477
4478 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4479 COBC_HD_CONFIGURATION_SECTION,
4480 COBC_HD_SPECIAL_NAMES, 0);
4481 if (current_program->nested_level) {
4482 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4483 } else {
4484 /* Returns null on error */
4485 x = cb_build_class_name ($2, $5);
4486 if (x) {
4487 current_program->class_name_list =
4488 cb_list_add (current_program->class_name_list, x);
4489 }
4490 }
4491 }
4492 ;
4493
4494 class_item_list:
4495 class_item { $$ = CB_LIST_INIT ($1); }
4496 | class_item_list class_item { $$ = cb_list_add ($1, $2); }
4497 ;
4498
4499 class_item:
4500 class_value
4501 {
4502 $$ = $1;
4503 }
4504 | class_value THRU class_value
4505 {
4506 if (CB_TREE_CLASS ($1) != CB_CLASS_NUMERIC &&
4507 CB_LITERAL_P ($1) && CB_LITERAL ($1)->size != 1) {
4508 cb_error (_("CLASS literal with THRU must have size 1"));
4509 }
4510 if (CB_TREE_CLASS ($3) != CB_CLASS_NUMERIC &&
4511 CB_LITERAL_P ($3) && CB_LITERAL ($3)->size != 1) {
4512 cb_error (_("CLASS literal with THRU must have size 1"));
4513 }
4514 if (literal_value ($1) <= literal_value ($3)) {
4515 $$ = CB_BUILD_PAIR ($1, $3);
4516 } else {
4517 $$ = CB_BUILD_PAIR ($3, $1);
4518 }
4519 }
4520 ;
4521
4522 _class_type:
4523 /* empty */
4524 | _for ALPHANUMERIC
4525 {
4526 $$ = NULL;
4527 }
4528 | _for NATIONAL
4529 {
4530 CB_PENDING_X ($2, "NATIONAL CLASS");
4531 $$ = cb_int0;
4532 }
4533 ;
4534
4535 _in_alphabet:
4536 /* empty */
4537 | IN alphabet_name
4538 {
4539 CB_PENDING_X ($2, _("CLASS IS integer IN alphabet-name"));
4540 $$ = $2;
4541 }
4542 ;
4543
4544 /* LOCALE clause */
4545
4546 locale_clause:
4547 LOCALE undefined_word _is LITERAL
4548 {
4549 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4550 COBC_HD_CONFIGURATION_SECTION,
4551 COBC_HD_SPECIAL_NAMES, 0);
4552 if (current_program->nested_level) {
4553 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4554 } else {
4555 /* Returns null on error */
4556 cb_tree l = cb_build_locale_name ($2, $4);
4557 if (l) {
4558 current_program->locale_list =
4559 cb_list_add (current_program->locale_list, l);
4560 }
4561 }
4562 }
4563 ;
4564
4565 /* CURRENCY SIGN clause */
4566
4567 currency_sign_clause:
4568 CURRENCY _sign _is LITERAL _with_pic_symbol
4569 {
4570 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4571 COBC_HD_CONFIGURATION_SECTION,
4572 COBC_HD_SPECIAL_NAMES, 0);
4573 if (current_program->nested_level) {
4574 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4575 } else {
4576 unsigned int error_ind = 0;
4577
4578 /* FIXME: actual allowed (depending on dialect), see FR #246 */
4579 check_repeated ("CURRENCY", SYN_CLAUSE_1, &check_duplicate);
4580
4581 /* checks of CURRENCY SIGN (being currency string) when separate */
4582 if ($5) {
4583 unsigned int char_seen = 0;
4584 unsigned char *s = CB_LITERAL ($4)->data;
4585
4586 CB_PENDING_X ($4, _("separate currency symbol and currency string"));
4587 while (*s) {
4588 switch (*s) {
4589 case '0':
4590 case '1':
4591 case '2':
4592 case '3':
4593 case '4':
4594 case '5':
4595 case '6':
4596 case '7':
4597 case '8':
4598 case '9':
4599 case '+':
4600 case '-':
4601 case ',':
4602 case '.':
4603 case '*':
4604 error_ind = 1;
4605 break;
4606 case ' ':
4607 break;
4608 default:
4609 char_seen = 1;
4610 break;
4611 }
4612 s++;
4613 }
4614 if (!char_seen) {
4615 error_ind = 1;
4616 }
4617 }
4618 if (error_ind) {
4619 cb_error_x ($4, _("invalid CURRENCY SIGN '%s'"), (char*)CB_LITERAL ($4)->data);
4620 }
4621 if ($5) {
4622 set_currency_picture_symbol ($5);
4623 } else {
4624 if (!error_ind) {
4625 set_currency_picture_symbol ($4);
4626 }
4627 }
4628 }
4629 }
4630 ;
4631
4632
4633 _with_pic_symbol:
4634 /* empty */
4635 {
4636 $$ = NULL;
4637 }
4638 | _with PICTURE_SYMBOL LITERAL
4639 {
4640 $$ = $3;
4641 }
4642 ;
4643
4644 /* DECIMAL-POINT clause */
4645
4646 decimal_point_clause:
4647 DECIMAL_POINT _is COMMA
4648 {
4649 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4650 COBC_HD_CONFIGURATION_SECTION,
4651 COBC_HD_SPECIAL_NAMES, 0);
4652 if (current_program->nested_level) {
4653 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4654 } else {
4655 check_repeated ("DECIMAL-POINT", SYN_CLAUSE_2, &check_duplicate);
4656 current_program->decimal_point = ',';
4657 current_program->numeric_separator = '.';
4658 }
4659 }
4660 ;
4661
4662
4663 /* NUMERIC SIGN clause */
4664
4665 numeric_sign_clause:
4666 NUMERIC SIGN _is TRAILING SEPARATE
4667 {
4668 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4669 COBC_HD_CONFIGURATION_SECTION,
4670 COBC_HD_SPECIAL_NAMES, 0);
4671 if (current_program->nested_level) {
4672 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4673 } else {
4674 current_program->flag_trailing_separate = 1;
4675 }
4676 }
4677 ;
4678
4679 /* CURSOR clause */
4680
4681 cursor_clause:
4682 CURSOR _is reference
4683 {
4684 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4685 COBC_HD_CONFIGURATION_SECTION,
4686 COBC_HD_SPECIAL_NAMES, 0);
4687 if (current_program->nested_level) {
4688 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4689 } else {
4690 check_repeated ("CURSOR", SYN_CLAUSE_3, &check_duplicate);
4691 current_program->cursor_pos = $3;
4692 }
4693 }
4694 ;
4695
4696
4697 /* CRT STATUS clause */
4698
4699 crt_status_clause:
4700 CRT STATUS _is reference
4701 {
4702 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4703 COBC_HD_CONFIGURATION_SECTION,
4704 COBC_HD_SPECIAL_NAMES, 0);
4705 if (current_program->nested_level) {
4706 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4707 } else {
4708 check_repeated ("CRT STATUS", SYN_CLAUSE_4, &check_duplicate);
4709 current_program->crt_status = $4;
4710 }
4711 }
4712 ;
4713
4714
4715 /* SCREEN CONTROL */
4716
4717 screen_control:
4718 SCREEN_CONTROL _is reference
4719 {
4720 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4721 COBC_HD_CONFIGURATION_SECTION,
4722 COBC_HD_SPECIAL_NAMES, 0);
4723 if (current_program->nested_level) {
4724 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4725 } else {
4726 check_repeated ("SCREEN CONTROL", SYN_CLAUSE_5, &check_duplicate);
4727 CB_PENDING ("SCREEN CONTROL");
4728 }
4729 }
4730 ;
4731
4732 /* EVENT STATUS */
4733
4734 event_status:
4735 EVENT_STATUS _is reference
4736 {
4737 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4738 COBC_HD_CONFIGURATION_SECTION,
4739 COBC_HD_SPECIAL_NAMES, 0);
4740 if (current_program->nested_level) {
4741 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4742 } else {
4743 check_repeated ("EVENT STATUS", SYN_CLAUSE_6, &check_duplicate);
4744 CB_PENDING ("EVENT STATUS");
4745 }
4746 }
4747 ;
4748
4749 /* TOP clause */
4750
4751 top_clause:
4752 TOP
4753 {
4754 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4755 COBC_HD_CONFIGURATION_SECTION,
4756 COBC_HD_SPECIAL_NAMES, 0);
4757 check_duplicate = 0;
4758 if (current_program->nested_level) {
4759 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
4760 save_tree = NULL;
4761 } else {
4762 /* lookup system name
4763 note: result in NULL + raised error if not found */
4764 save_tree = get_system_name ("TOP");
4765 }
4766 }
4767 _is undefined_word
4768 {
4769 if (save_tree && CB_VALID_TREE ($4)) {
4770 cb_define ($4, save_tree);
4771 CB_CHAIN_PAIR (current_program->mnemonic_spec_list,
4772 $4, save_tree);
4773 }
4774 }
4775 ;
4776
4777 /* INPUT-OUTPUT SECTION */
4778
4779 _input_output_section:
4780 _input_output_header
4781 _file_control_header
4782 _file_control_sequence
4783 _i_o_control
4784 ;
4785
4786 _input_output_header:
4787 | INPUT_OUTPUT SECTION TOK_DOT
4788 {
4789 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION, 0, 0, 0);
4790 header_check |= COBC_HD_INPUT_OUTPUT_SECTION;
4791 }
4792 ;
4793
4794 /* FILE-CONTROL paragraph */
4795
4796 _file_control_header:
4797 | FILE_CONTROL TOK_DOT
4798 {
4799 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4800 COBC_HD_INPUT_OUTPUT_SECTION, 0, 0);
4801 header_check |= COBC_HD_FILE_CONTROL;
4802 }
4803 ;
4804
4805 _file_control_sequence:
4806 | _file_control_sequence file_control_entry
4807 ;
4808
4809 file_control_entry:
4810 SELECT flag_optional undefined_word
4811 {
4812 char buff[COB_MINI_BUFF];
4813
4814 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
4815 COBC_HD_INPUT_OUTPUT_SECTION,
4816 COBC_HD_FILE_CONTROL, 0);
4817 check_duplicate = 0;
4818 if (CB_VALID_TREE ($3)) {
4819 /* Build new file */
4820 current_file = build_file ($3);
4821 current_file->optional = CB_INTEGER ($2)->val;
4822
4823 /* Add file to current program list */
4824 CB_ADD_TO_CHAIN (CB_TREE (current_file),
4825 current_program->file_list);
4826 } else {
4827 /* Create dummy file */
4828 snprintf (buff, COB_MINI_BUFF, "SELECT on line %d",
4829 cb_source_line);
4830 current_file = build_file (cb_build_reference (buff));
4831 CB_ADD_TO_CHAIN (CB_TREE (current_file),
4832 current_program->file_list);
4833
4834 }
4835 key_type = NO_KEY;
4836 }
4837 _select_clauses_or_error
4838 {
4839 cobc_cs_check = 0;
4840 if (CB_VALID_TREE ($3)) {
4841 if (current_file->organization == COB_ORG_INDEXED
4842 && key_type == RELATIVE_KEY) {
4843 cb_error_x (current_file->key,
4844 _("cannot use RELATIVE KEY clause on INDEXED files"));
4845 } else if (current_file->organization == COB_ORG_RELATIVE
4846 && key_type == RECORD_KEY) {
4847 cb_error_x (current_file->key,
4848 _("cannot use RECORD KEY clause on RELATIVE files"));
4849 }
4850
4851 validate_file (current_file, $3);
4852 }
4853 }
4854 ;
4855
4856 _select_clauses_or_error:
4857 _select_clause_sequence TOK_DOT
4858 | error TOK_DOT
4859 {
4860 yyerrok;
4861 }
4862 ;
4863
4864 _select_clause_sequence:
4865 | _select_clause_sequence select_clause
4866 {
4867 /* reset context-sensitive words for next clauses */
4868 cobc_cs_check = CB_CS_SELECT;
4869 }
4870 ;
4871
4872 /* duplicates are checked - but not the order... */
4873 select_clause:
4874 assign_clause
4875 | reserve_clause
4876 | organization_clause
4877 | padding_character_clause
4878 | record_delimiter_clause
4879 | access_mode_clause
4880 | relative_key_clause
4881 | collating_sequence_clause
4882 | collating_sequence_clause_key
4883 | record_key_clause
4884 | alternative_record_key_clause
4885 | file_status_clause
4886 | lock_mode_clause
4887 | sharing_clause
4888 | file_limit_clause
4889 | actual_key_clause
4890 | nominal_key_clause
4891 | track_area_clause
4892 | track_limit_clause
4893 /* FXIME: disabled because of shift/reduce conflict
4894 | encryption_clause
4895 */
4896 /* FXIME: disabled because of shift/reduce conflict
4897 (optional in [alternate] record key, could be moved here
4898 if the suppress_clause goes here too and both entries verify that
4899 they directly are invoked after an [alternate] record key)
4900 | password_clause
4901 {
4902 if (current_file->organization == COB_ORG_INDEXED) {
4903 cb_error (_("for indexed files, the PASSWORD phrase must follow KEY"));
4904 } else {
4905 current_file->password = $1;
4906 }
4907 }
4908 */
4909 ;
4910
4911
4912 /* ASSIGN clause */
4913
4914 /*
4915 Most cases include a pointless _ext_clause to prevent a shift/reduce error
4916 */
4917 assign_clause:
4918 ASSIGN _to _ext_clause _assign_device_or_line_adv_file literal
4919 {
4920 check_repeated ("ASSIGN", SYN_CLAUSE_1, &check_duplicate);
4921 if (ext_dyn_specified) {
4922 cb_error (_("EXTERNAL/DYNAMIC cannot be used with literals"));
4923 }
4924
4925 current_file->assign_type = CB_ASSIGN_EXT_FILE_NAME_REQUIRED;
4926 current_file->assign = cb_build_assignment_name (current_file, $5);
4927 }
4928 | ASSIGN _to _ext_clause _assign_device_or_line_adv_file qualified_word
4929 {
4930 check_repeated ("ASSIGN", SYN_CLAUSE_1, &check_duplicate);
4931
4932 /* current_file->assign_type is set by _ext_clause */
4933 if (!ext_dyn_specified) {
4934 current_file->flag_assign_no_keyword = 1;
4935 }
4936 current_file->assign = cb_build_assignment_name (current_file, $5);
4937 }
4938 | ASSIGN _to _ext_clause _assign_device_or_line_adv_file using_or_varying qualified_word
4939 {
4940 check_repeated ("ASSIGN", SYN_CLAUSE_1, &check_duplicate);
4941 if (ext_dyn_specified) {
4942 cb_error (_("EXTERNAL/DYNAMIC cannot be used with USING/VARYING"));
4943 }
4944 cb_verify (cb_assign_using_variable, "ASSIGN USING/VARYING variable");
4945
4946 current_file->assign_type = CB_ASSIGN_VARIABLE_REQUIRED;
4947 current_file->assign = cb_build_assignment_name (current_file, $6);
4948 }
4949 | ASSIGN _to _ext_clause DISK FROM qualified_word
4950 {
4951 check_repeated ("ASSIGN", SYN_CLAUSE_1, &check_duplicate);
4952 if (ext_dyn_specified) {
4953 cb_error (_("EXTERNAL/DYNAMIC cannot be used with DISK FROM"));
4954 }
4955 cb_verify (cb_assign_disk_from, _("ASSIGN DISK FROM"));
4956
4957 current_file->assign_type = CB_ASSIGN_VARIABLE_REQUIRED;
4958 current_file->assign = cb_build_assignment_name (current_file, $6);
4959 }
4960 | ASSIGN _to _ext_clause assign_device
4961 {
4962 if (assign_device == CB_ASSIGN_DISPLAY_DEVICE) {
4963 current_file->assign =
4964 cb_build_alphanumeric_literal ("stdout", (size_t)6);
4965 current_file->special = COB_SELECT_STDOUT;
4966 } else if (assign_device == CB_ASSIGN_KEYBOARD_DEVICE) {
4967 current_file->assign =
4968 cb_build_alphanumeric_literal ("stdin", (size_t)5);
4969 current_file->special = COB_SELECT_STDIN;
4970 } else if (assign_device == CB_ASSIGN_PRINTER_DEVICE) {
4971 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
4972 current_file->assign =
4973 cb_build_alphanumeric_literal ("PRINTER", (size_t)7);
4974 } else if (assign_device == CB_ASSIGN_PRINTER_1_DEVICE) {
4975 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
4976 current_file->assign =
4977 cb_build_alphanumeric_literal ("PRINTER-1", (size_t)9);
4978 } else if (assign_device == CB_ASSIGN_PRINT_DEVICE) {
4979 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
4980 current_file->assign =
4981 cb_build_alphanumeric_literal ("LPT1", (size_t)4);
4982 } else if (assign_device == CB_ASSIGN_LINE_SEQ_DEVICE
4983 || assign_device == CB_ASSIGN_GENERAL_DEVICE) {
4984 current_file->flag_fileid = 1;
4985 }
4986 }
4987 ;
4988
4989 _assign_device_or_line_adv_file:
4990 /* empty */
4991 {
4992 assign_device = CB_ASSIGN_NO_DEVICE;
4993 }
4994 | line_adv_file
4995 {
4996 assign_device = CB_ASSIGN_NO_DEVICE;
4997 }
4998 | assign_device
4999 ;
5000
5001 assign_device:
5002 general_device_name
5003 {
5004 assign_device = CB_ASSIGN_GENERAL_DEVICE;
5005 }
5006 | line_seq_device_name
5007 {
5008 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
5009 assign_device = CB_ASSIGN_LINE_SEQ_DEVICE;
5010 }
5011 | DISPLAY
5012 {
5013 assign_device = CB_ASSIGN_DISPLAY_DEVICE;
5014 }
5015 | KEYBOARD
5016 {
5017 assign_device = CB_ASSIGN_KEYBOARD_DEVICE;
5018 }
5019 /* Hint: R/M-COBOL has PRINTER01 thru PRINTER99 !
5020 MF-COBOL handles these identical to PRINTER-1,
5021 with an optional file name PRINTER01 thru PRINTER99
5022 */
5023 | PRINTER
5024 {
5025 assign_device = CB_ASSIGN_PRINTER_DEVICE;
5026 }
5027 | PRINTER_1
5028 {
5029 assign_device = CB_ASSIGN_PRINTER_1_DEVICE;
5030 }
5031 | PRINT
5032 {
5033 assign_device = CB_ASSIGN_PRINT_DEVICE;
5034 }
5035 ;
5036
5037 /* Indicates no special processing */
5038 general_device_name:
5039 DISC
5040 | DISK
5041 | TAPE
5042 | RANDOM
5043 ;
5044
5045 line_seq_device_name:
5046 CARD_PUNCH
5047 | CARD_READER
5048 | CASSETTE
5049 | INPUT
5050 | INPUT_OUTPUT
5051 | MAGNETIC_TAPE
5052 | OUTPUT
5053 ;
5054
5055 line_adv_file:
5056 LINE ADVANCING _file
5057 {
5058 current_file->flag_line_adv = 1;
5059 }
5060 ;
5061
5062 _ext_clause:
5063 /* empty */
5064 {
5065 ext_dyn_specified = 0;
5066 current_file->assign_type = cb_assign_type_default;
5067 }
5068 | ext_clause
5069 {
5070 ext_dyn_specified = 1;
5071 cb_verify (cb_assign_ext_dyn, _("ASSIGN EXTERNAL/DYNAMIC"));
5072 }
5073 ;
5074
5075 ext_clause:
5076 EXTERNAL
5077 {
5078 current_file->assign_type = CB_ASSIGN_EXT_FILE_NAME_REQUIRED;
5079 }
5080 | DYNAMIC
5081 {
5082 current_file->assign_type = CB_ASSIGN_VARIABLE_REQUIRED;
5083 }
5084 ;
5085
5086 assignment_name:
5087 LITERAL
5088 | qualified_word
5089 ;
5090
5091 /* ACCESS MODE clause */
5092
5093 access_mode_clause:
5094 ACCESS _mode _is access_mode
5095 {
5096 check_repeated ("ACCESS", SYN_CLAUSE_2, &check_duplicate);
5097 }
5098 ;
5099
5100 access_mode:
5101 SEQUENTIAL { current_file->access_mode = COB_ACCESS_SEQUENTIAL; }
5102 | DYNAMIC { current_file->access_mode = COB_ACCESS_DYNAMIC; }
5103 | RANDOM { current_file->access_mode = COB_ACCESS_RANDOM; }
5104 ;
5105
5106
5107 /* ALTERNATIVE RECORD KEY clause */
5108
5109 alternative_record_key_clause:
5110 ALTERNATE _record _key _is reference _split_keys flag_duplicates _password_clause _suppress_clause
5111 {
5112 struct cb_alt_key *p;
5113 struct cb_alt_key *l;
5114
5115 cb_tree composite_key;
5116
5117 p = cobc_parse_malloc (sizeof (struct cb_alt_key));
5118 p->key = $5;
5119 p->component_list = NULL;
5120 if ($7) {
5121 p->duplicates = CB_INTEGER ($7)->val;
5122 } else {
5123 /* note: we may add a compiler configuration here,
5124 as at least ICOBOL defaults to WITH DUPLICATES
5125 for ALTERNATE keys if not explicit deactivated
5126 */
5127 p->duplicates = 0;
5128 }
5129 p->password = $8;
5130 if ($9) {
5131 p->tf_suppress = 1;
5132 p->char_suppress = CB_INTEGER ($9)->val;
5133 } else {
5134 p->tf_suppress = 0;
5135 }
5136 p->next = NULL;
5137
5138 /* handle split keys */
5139 if ($6) {
5140 /* generate field (in w-s) for composite-key */
5141 composite_key = cb_build_field($5);
5142 if (composite_key == cb_error_node) {
5143 YYERROR;
5144 } else {
5145 composite_key->category = CB_CATEGORY_ALPHANUMERIC;
5146 ((struct cb_field *)composite_key)->count = 1;
5147 p->key = cb_build_field_reference((struct cb_field *)composite_key, NULL);
5148 p->component_list = key_component_list;
5149 }
5150 }
5151
5152 /* Add to the end of list */
5153 if (current_file->alt_key_list == NULL) {
5154 current_file->alt_key_list = p;
5155 } else {
5156 l = current_file->alt_key_list;
5157 for (; l->next; l = l->next) { ; }
5158 l->next = p;
5159 }
5160 }
5161 ;
5162
5163 _password_clause:
5164 /* empty */
5165 {
5166 $$ = NULL;
5167 }
5168 | password_clause
5169 ;
5170
5171 password_clause:
5172 PASSWORD
5173 {
5174 CB_PENDING ("PASSWORD clause");
5175 }
5176 _is reference
5177 {
5178 $$ = $4;
5179 }
5180 ;
5181
5182 /* FXIME: disabled because of shift/reduce conflict
5183 encryption_clause:
5184 _with ENCRYPTION
5185 {
5186 if (current_file->organization == COB_ORG_INDEXED) {
5187 cb_error (_("%s only valid with ORGANIZATION %s"), "WITH ENCRYPTION", "INDEXED");
5188 } else {
5189 CB_PENDING ("WITH ENCRYPTION");
5190 current_file->password = cb_int0;
5191 }
5192 }
5193 ;
5194 */
5195
5196 _suppress_clause:
5197 /* empty */
5198 {
5199 $$ = NULL;
5200 }
5201 | SUPPRESS WHEN ALL basic_value
5202 {
5203 $$ = cb_int (literal_value ($4));
5204 }
5205 | SUPPRESS WHEN space_or_zero
5206 {
5207 $$ = cb_int (literal_value ($3));
5208 }
5209 ;
5210
5211
5212 /* COLLATING SEQUENCE clause */
5213
5214 collating_sequence_clause:
5215 collating_sequence
5216 {
5217 check_repeated ("COLLATING", SYN_CLAUSE_3, &check_duplicate);
5218 current_file->collating_sequence = alphanumeric_collation;
5219 current_file->collating_sequence_n = national_collation;
5220 CB_PENDING ("FILE COLLATING SEQUENCE");
5221 }
5222 ;
5223
5224 collating_sequence:
5225 _collating SEQUENCE
5226 {
5227 alphanumeric_collation = national_collation = NULL;
5228 }
5229 coll_sequence_values
5230 ;
5231
5232 coll_sequence_values:
5233 _is alphabet_name
5234 {
5235 alphanumeric_collation = $2;
5236 }
5237 | _is alphabet_name alphabet_name
5238 {
5239 alphanumeric_collation = $2;
5240 CB_PENDING_X ($3, "NATIONAL COLLATING SEQUENCE");
5241 national_collation = $3;
5242 }
5243 | _for ALPHANUMERIC _is alphabet_name
5244 {
5245 alphanumeric_collation = $4;
5246 }
5247 | _for NATIONAL _is alphabet_name
5248 {
5249 CB_PENDING_X ($4, "NATIONAL COLLATING SEQUENCE");
5250 national_collation = $4;
5251 }
5252 | _for ALPHANUMERIC _is alphabet_name
5253 _for NATIONAL _is alphabet_name
5254 {
5255 alphanumeric_collation = $4;
5256 CB_PENDING_X ($8, "NATIONAL COLLATING SEQUENCE");
5257 national_collation = $8;
5258 }
5259 | _for NATIONAL _is alphabet_name
5260 _for ALPHANUMERIC _is alphabet_name
5261 {
5262 CB_PENDING_X ($4, "NATIONAL COLLATING SEQUENCE");
5263 national_collation = $4;
5264 alphanumeric_collation = $8;
5265 }
5266 ;
5267
5268 collating_sequence_clause_key:
5269 _collating SEQUENCE OF reference _is alphabet_name
5270 {
5271 /* note: both entries must be resolved later on
5272 and also attached to the correct key later, so just store in a list here: */
5273 current_file->collating_sequence_keys =
5274 cb_list_add(current_file->collating_sequence_keys, CB_BUILD_PAIR ($6, $4));
5275 CB_PENDING ("KEY COLLATING SEQUENCE");
5276 }
5277 ;
5278
5279 alphabet_name:
5280 WORD
5281 {
5282 if (CB_ALPHABET_NAME_P (cb_ref ($1))) {
5283 $$ = $1;
5284 } else {
5285 cb_error_x ($1, _("'%s' is not an alphabet-name"),
5286 cb_name ($1));
5287 $$ = cb_error_node;
5288 }
5289 }
5290 ;
5291
5292 /* FILE STATUS clause */
5293
5294 file_status_clause:
5295 _file_or_sort STATUS _is reference _reference
5296 {
5297 check_repeated ("STATUS", SYN_CLAUSE_4, &check_duplicate);
5298 current_file->file_status = $4;
5299 if ($5) {
5300 /* Ignore VSAM STATUS field */
5301 cb_verify (cb_vsam_status, _("VSAM status"));
5302 }
5303 }
5304 ;
5305
5306 _file_or_sort:
5307 /* empty */
5308 | TOK_FILE
5309 | SORT
5310 ;
5311
5312 /* LOCK MODE clause */
5313
5314 lock_mode_clause:
5315 {
5316 check_repeated ("LOCK", SYN_CLAUSE_5, &check_duplicate);
5317 }
5318 LOCK _mode _is lock_mode
5319 ;
5320
5321 lock_mode:
5322 MANUAL _lock_with
5323 {
5324 current_file->lock_mode |= COB_LOCK_MANUAL;
5325 }
5326 | AUTOMATIC _lock_with
5327 {
5328 current_file->lock_mode |= COB_LOCK_AUTOMATIC;
5329 }
5330 | EXCLUSIVE _with_mass_update
5331 {
5332 current_file->lock_mode |= COB_LOCK_EXCLUSIVE;
5333 }
5334 ;
5335
5336 /* FIXME: the following WITH is optional (shift/reduce conflict) */
5337 _lock_with:
5338 | WITH _lock ON lock_records _with_rollback
5339 | WITH _lock ON MULTIPLE lock_records _with_rollback
5340 {
5341 current_file->lock_mode |= COB_LOCK_MULTIPLE;
5342 }
5343 | with_rollback
5344 {
5345 current_file->lock_mode |= COB_LOCK_MULTIPLE;
5346 }
5347 ;
5348
5349 _with_rollback:
5350 | with_rollback
5351 ;
5352
5353 with_rollback:
5354 _with ROLLBACK
5355 {
5356 CB_PENDING ("WITH ROLLBACK");
5357 }
5358 ;
5359
5360 _with_mass_update:
5361 | _with MASS_UPDATE
5362 {
5363 if (current_file->organization == COB_ORG_INDEXED) {
5364 current_file->lock_mode |= COB_LOCK_EXCLUSIVE;
5365 /* TODO: pass extra flag to fileio */
5366 CB_PENDING ("WITH MASS-UPDATE");
5367 } else {
5368 cb_error (_("%s only valid with ORGANIZATION %s"), "MASS-UPDATE", "INDEXED");
5369 }
5370 }
5371 ;
5372
5373
5374 /* ORGANIZATION clause */
5375
5376 organization_clause:
5377 ORGANIZATION _is organization
5378 | organization
5379 ;
5380
5381 organization:
5382 INDEXED
5383 {
5384 check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate);
5385 error_if_record_delimiter_incompatible (COB_ORG_INDEXED, "INDEXED");
5386 current_file->organization = COB_ORG_INDEXED;
5387 }
5388 | _record _binary SEQUENTIAL
5389 {
5390 check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate);
5391 error_if_record_delimiter_incompatible (COB_ORG_SEQUENTIAL, "SEQUENTIAL");
5392 current_file->organization = COB_ORG_SEQUENTIAL;
5393 }
5394 | RELATIVE
5395 {
5396 check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate);
5397 error_if_record_delimiter_incompatible (COB_ORG_RELATIVE, "RELATIVE");
5398 current_file->organization = COB_ORG_RELATIVE;
5399 }
5400 | LINE SEQUENTIAL
5401 {
5402 check_repeated ("ORGANIZATION", SYN_CLAUSE_6, &check_duplicate);
5403 error_if_record_delimiter_incompatible (COB_ORG_LINE_SEQUENTIAL,
5404 "LINE SEQUENTIAL");
5405 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
5406 }
5407 ;
5408
5409
5410 /* PADDING CHARACTER clause */
5411
5412 padding_character_clause:
5413 PADDING _character _is reference_or_literal
5414 {
5415 check_repeated ("PADDING", SYN_CLAUSE_7, &check_duplicate);
5416 cb_verify (cb_padding_character_clause, "PADDING CHARACTER");
5417 }
5418 ;
5419
5420 /* RECORD DELIMITER clause */
5421
5422 record_delimiter_clause:
5423 RECORD DELIMITER _is
5424 {
5425 check_repeated ("RECORD DELIMITER", SYN_CLAUSE_8, &check_duplicate);
5426 current_file->flag_delimiter = 1;
5427 }
5428 record_delimiter_option
5429 ;
5430
5431 record_delimiter_option:
5432 STANDARD_1
5433 {
5434 if (current_file->organization != COB_ORG_SEQUENTIAL) {
5435 cb_error (_("RECORD DELIMITER %s only allowed with SEQUENTIAL files"),
5436 "STANDARD-1");
5437 current_file->flag_delimiter = 0;
5438 } else if (cb_verify (cb_record_delimiter, _("RECORD DELIMITER clause"))) {
5439 cb_warning (cb_warn_additional,
5440 _("%s ignored"), "RECORD DELIMITER STANDARD-1");
5441 }
5442 }
5443 | LINE_SEQUENTIAL
5444 {
5445 if (current_file->organization != COB_ORG_SEQUENTIAL
5446 && current_file->organization != COB_ORG_LINE_SEQUENTIAL) {
5447 cb_error (_("RECORD DELIMITER %s only allowed with (LINE) SEQUENTIAL files"),
5448 "LINE-SEQUENTIAL");
5449 current_file->flag_delimiter = 0;
5450 }
5451
5452 if (cb_verify (cb_record_delimiter, _("RECORD DELIMITER clause"))
5453 && cb_verify (cb_sequential_delimiters, _("LINE-SEQUENTIAL phrase"))) {
5454 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
5455 }
5456 }
5457 | BINARY_SEQUENTIAL
5458 {
5459 if (current_file->organization != COB_ORG_SEQUENTIAL) {
5460 cb_error (_("RECORD DELIMITER %s only allowed with SEQUENTIAL files"),
5461 "BINARY-SEQUENTIAL");
5462 current_file->flag_delimiter = 0;
5463 }
5464
5465 if (cb_verify (cb_record_delimiter, _("RECORD DELIMITER clause"))
5466 && cb_verify (cb_sequential_delimiters, _("BINARY-SEQUENTIAL phrase"))) {
5467 current_file->organization = COB_ORG_SEQUENTIAL;
5468 }
5469 }
5470 | WORD
5471 {
5472 if (current_file->organization != COB_ORG_SEQUENTIAL
5473 && current_file->organization != COB_ORG_LINE_SEQUENTIAL) {
5474 cb_error (_("RECORD DELIMITER clause only allowed with (LINE) SEQUENTIAL files"));
5475 current_file->flag_delimiter = 0;
5476 } else if (cb_verify (cb_record_delimiter, _("RECORD DELIMITER clause"))) {
5477 cb_warning (cb_warn_additional,
5478 _("RECORD DELIMITER %s not recognized; will be ignored"), cb_name ($1));
5479 }
5480 }
5481 ;
5482
5483 /* RECORD KEY clause */
5484
5485 record_key_clause:
5486 RECORD _key _is reference _split_keys _password_clause flag_duplicates
5487 {
5488 cb_tree composite_key;
5489
5490 check_repeated ("RECORD KEY", SYN_CLAUSE_9, &check_duplicate);
5491 current_file->key = $4;
5492 key_type = RECORD_KEY;
5493
5494 /* handle split keys */
5495 if ($5) {
5496 /* generate field (in w-s) for composite-key */
5497 composite_key = cb_build_field ($4);
5498 if (composite_key == cb_error_node) {
5499 YYERROR;
5500 } else {
5501 composite_key->category = CB_CATEGORY_ALPHANUMERIC;
5502 ((struct cb_field *)composite_key)->count = 1;
5503 current_file->key = cb_build_field_reference ((struct cb_field *)composite_key, NULL);
5504 current_file->component_list = key_component_list;
5505 }
5506 }
5507 current_file->password = $6;
5508 if ($7) {
5509 /* note: we *may* add a compiler configuration here,
5510 as most dialects do not allow this clause
5511 on primary keys */
5512 if (CB_INTEGER ($7)->val) {
5513 /* note: see ACUCOBOL docs for implementation notes, including [RE]WRITE rules
5514 and "if the underlying (file) system does not support them OPEN
5515 result in (sucessfull) io-status 0M" */
5516 CB_PENDING (_("DUPLICATES for primary keys"));
5517 };
5518
5519 }
5520 }
5521 ;
5522
5523 _split_keys:
5524 /* empty*/
5525 {
5526 $$ = NULL;
5527 }
5528 | source_is split_key_list
5529 {
5530 $$ = cb_int0;
5531 }
5532 ;
5533
5534 source_is:
5535 TOK_EQUAL
5536 | SOURCE _is
5537 ;
5538
5539 split_key_list:
5540 {
5541 key_component_list = NULL;
5542 }
5543 split_key
5544 | split_key_list split_key
5545 ;
5546
5547
5548 split_key:
5549 reference
5550 {
5551 struct cb_key_component *c;
5552 struct cb_key_component *comp = cobc_main_malloc (sizeof(struct cb_key_component));
5553 comp->next = NULL;
5554 comp->component = $1;
5555 if (key_component_list == NULL) {
5556 key_component_list = comp;
5557 } else {
5558 for (c = key_component_list; c->next != NULL; c = c->next);
5559 c->next = comp;
5560 }
5561 }
5562 ;
5563
5564 /* RELATIVE KEY clause */
5565
5566 relative_key_clause:
5567 RELATIVE _key _is reference
5568 {
5569 check_repeated ("RELATIVE KEY", SYN_CLAUSE_10, &check_duplicate);
5570 current_file->key = $4;
5571 key_type = RELATIVE_KEY;
5572 }
5573 ;
5574
5575 /* RESERVE clause */
5576
5577 reserve_clause:
5578 RESERVE no_or_integer _areas
5579 {
5580 check_repeated ("RESERVE", SYN_CLAUSE_11, &check_duplicate);
5581 }
5582 ;
5583
5584 no_or_integer:
5585 NO
5586 | integer
5587 ;
5588
5589 /* SHARING clause */
5590
5591 sharing_clause:
5592 SHARING _with sharing_option
5593 {
5594 check_repeated ("SHARING", SYN_CLAUSE_12, &check_duplicate);
5595 current_file->sharing = $3;
5596 }
5597 ;
5598
5599 sharing_option:
5600 /* code from trunk not available in 3.1 yet
5601 ALL _other { $$ = cb_int (COB_SHARE_ALL_OTHER); }
5602 | NO _other { $$ = cb_int (COB_SHARE_NO_OTHER); }
5603 | READ ONLY { $$ = cb_int (COB_SHARE_READ_ONLY); }
5604 current code: */
5605 ALL _other { $$ = NULL; }
5606 | NO _other { $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE); }
5607 | READ ONLY { $$ = NULL; }
5608 ;
5609
5610 /* FILE-LIMIT clause */
5611
5612 file_limit_clause:
5613 file_limit_or_limits _is_are thru_list
5614 {
5615 (void)cb_verify (CB_OBSOLETE, "FILE-LIMIT");
5616 check_repeated ("FILE-LIMIT", SYN_CLAUSE_13, &check_duplicate);
5617 }
5618 ;
5619
5620 thru_list:
5621 reference_or_literal THRU reference_or_literal
5622 | thru_list reference_or_literal THRU reference_or_literal
5623 ;
5624
5625 /* ACTUAL KEY clause */
5626
5627 actual_key_clause:
5628 ACTUAL _key _is reference
5629 {
5630 (void)cb_verify (CB_OBSOLETE, "ACTUAL KEY");
5631 check_repeated ("ACTUAL KEY", SYN_CLAUSE_14, &check_duplicate);
5632 }
5633 ;
5634
5635 /* NOMINAL KEY clause */
5636
5637 nominal_key_clause:
5638 NOMINAL _key _is reference
5639 {
5640 (void)cb_verify (CB_OBSOLETE, "NOMINAL KEY");
5641 check_repeated ("NOMINAL KEY", SYN_CLAUSE_15, &check_duplicate);
5642 }
5643 ;
5644
5645 /* TRACK-AREA clause */
5646
5647 track_area_clause:
5648 TRACK_AREA _is reference_or_literal _characters
5649 {
5650 (void)cb_verify (CB_OBSOLETE, "TRACK-AREA");
5651 check_repeated ("TRACK-AREA", SYN_CLAUSE_16, &check_duplicate);
5652 }
5653 ;
5654
5655 /* TRACK-LIMIT clause */
5656
5657 track_limit_clause:
5658 TRACK_LIMIT _is integer track_or_tracks
5659 {
5660 (void)cb_verify (CB_OBSOLETE, "TRACK-LIMIT");
5661 check_repeated ("TRACK-LIMIT", SYN_CLAUSE_17, &check_duplicate);
5662 }
5663
5664 ;
5665
5666 /* I-O-CONTROL paragraph */
5667
5668 _i_o_control:
5669 | i_o_control_header _i_o_control_entries
5670 {
5671 cobc_cs_check = 0;
5672 }
5673 ;
5674
5675 i_o_control_header:
5676 I_O_CONTROL TOK_DOT
5677 {
5678 check_headers_present(COBC_HD_ENVIRONMENT_DIVISION,
5679 COBC_HD_INPUT_OUTPUT_SECTION, 0, 0);
5680 header_check |= COBC_HD_I_O_CONTROL;
5681 }
5682 ;
5683
5684 _i_o_control_entries:
5685 | i_o_control_list TOK_DOT
5686 | i_o_control_list error TOK_DOT
5687 {
5688 yyerrok;
5689 }
5690 ;
5691
5692 i_o_control_list:
5693 i_o_control_clause
5694 | i_o_control_list i_o_control_clause
5695 ;
5696
5697 i_o_control_clause:
5698 same_clause
5699 | apply_clause
5700 | multiple_file_tape_clause
5701 | rerun_clause
5702 ;
5703
5704 /* SAME clause */
5705
5706 same_clause:
5707 SAME _same_option _area _for file_name_list
5708 {
5709 cb_tree l;
5710
5711 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
5712 COBC_HD_INPUT_OUTPUT_SECTION,
5713 COBC_HD_I_O_CONTROL, 0);
5714 switch (CB_INTEGER ($2)->val) {
5715 case 0:
5716 /* SAME AREA */
5717 break;
5718 case 1:
5719 /* SAME RECORD */
5720 for (l = $5; l; l = CB_CHAIN (l)) {
5721 if (CB_VALID_TREE (CB_VALUE (l))) {
5722 CB_FILE (cb_ref (CB_VALUE (l)))->same_clause = same_area;
5723 }
5724 }
5725 same_area++;
5726 break;
5727 case 2:
5728 /* SAME SORT-MERGE */
5729 break;
5730 }
5731 }
5732 ;
5733
5734 _same_option:
5735 /* empty */ { $$ = cb_int0; }
5736 | RECORD { $$ = cb_int1; }
5737 | SORT { $$ = cb_int2; }
5738 | SORT_MERGE { $$ = cb_int2; }
5739 ;
5740
5741 /* APPLY clause */
5742
5743 apply_clause:
5744 APPLY COMMIT _on reference_list
5745 {
5746 current_program->apply_commit = $4;
5747 CB_PENDING("APPLY COMMIT");
5748 }
5749 | APPLY LOCK_HOLDING _on file_name_list
5750 {
5751 CB_PENDING ("APPLY LOCK-HOLDING");
5752 }
5753 | APPLY PRINT_CONTROL _on file_name_list
5754 {
5755 CB_PENDING ("APPLY PRINT-CONTROL");
5756 }
5757 | APPLY WRITE_ONLY _on file_name_list
5758 | obsolete_dos_vs_apply_phrase
5759 {
5760 cb_verify (CB_OBSOLETE, _("DOS/VS APPLY phrase"));
5761 }
5762 ;
5763
5764 obsolete_dos_vs_apply_phrase:
5765 APPLY CORE_INDEX _to reference _on file_name_list
5766 | APPLY CYL_INDEX _to integer _on file_name_list
5767 | APPLY CYL_OVERFLOW _of integer track_or_tracks _on file_name_list
5768 | APPLY EXTENDED_SEARCH _on file_name_list
5769 | APPLY MASTER_INDEX _to integer _on file_name_list
5770 | APPLY RECORD_OVERFLOW _on file_name_list
5771 | APPLY REORG_CRITERIA _to reference _on file_name_list
5772 | APPLY WRITE_VERIFY _on file_name_list
5773 ;
5774
5775 /* MULTIPLE FILE TAPE clause */
5776
5777 multiple_file_tape_clause:
5778 MULTIPLE
5779 {
5780 /* Fake for TAPE */
5781 cobc_cs_check = CB_CS_ASSIGN;
5782 }
5783 _file _tape _contains multiple_file_list
5784 {
5785 check_headers_present (COBC_HD_ENVIRONMENT_DIVISION,
5786 COBC_HD_INPUT_OUTPUT_SECTION,
5787 COBC_HD_I_O_CONTROL, 0);
5788 cb_verify (cb_multiple_file_tape_clause, "MULTIPLE FILE TAPE");
5789 cobc_cs_check = 0;
5790 }
5791 ;
5792
5793 multiple_file_list:
5794 multiple_file
5795 | multiple_file_list multiple_file
5796 ;
5797
5798 multiple_file:
5799 file_name _multiple_file_position
5800 ;
5801
5802 _multiple_file_position:
5803 | POSITION integer
5804 ;
5805
5806 /* RERUN clause */
5807
5808 rerun_clause:
5809 RERUN _on_assignment _every rerun_event _of file_name
5810 ;
5811
5812 _on_assignment:
5813 _on assignment_name
5814 ;
5815
5816 rerun_event:
5817 integer RECORDS
5818 | END _of reel_or_unit
5819 ;
5820
5821 /* DATA DIVISION */
5822
5823 _data_division:
5824 _data_division_header
5825 _file_section_header
5826 _file_description_sequence
5827 {
5828 current_storage = CB_STORAGE_WORKING;
5829 }
5830 _working_storage_section
5831 _communication_section
5832 _local_storage_section
5833 _linkage_section
5834 _report_section
5835 _screen_section
5836 ;
5837
5838 _data_division_header:
5839 | data_division_header
5840 ;
5841
5842 data_division_header:
5843 DATA DIVISION TOK_DOT
5844 {
5845 header_check |= COBC_HD_DATA_DIVISION;
5846 }
5847 ;
5848
5849 /* FILE SECTION */
5850
5851 _file_section_header:
5852 | TOK_FILE SECTION TOK_DOT
5853 {
5854 current_storage = CB_STORAGE_FILE;
5855 check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
5856 header_check |= COBC_HD_FILE_SECTION;
5857 }
5858 ;
5859
5860 _file_description_sequence:
5861 | _file_description_sequence file_description
5862 ;
5863
5864 file_description:
5865 file_description_entry
5866 _record_description_list
5867 {
5868 if (CB_VALID_TREE (current_file)) {
5869 if (CB_VALID_TREE ($2)) {
5870 /* Do not keep Record if this is really a report */
5871 if (!current_file->reports) {
5872 finalize_file (current_file, CB_FIELD ($2));
5873 }
5874 } else if (!current_file->reports) {
5875 cb_error (_("RECORD description missing or invalid"));
5876 }
5877 }
5878 }
5879 ;
5880
5881 /* File description entry */
5882
5883 file_description_entry:
5884 file_type file_name
5885 {
5886 current_storage = CB_STORAGE_FILE;
5887 check_headers_present (COBC_HD_DATA_DIVISION,
5888 COBC_HD_FILE_SECTION, 0, 0);
5889 check_duplicate = 0;
5890 if (CB_INVALID_TREE ($2)) {
5891 current_file = NULL;
5892 YYERROR;
5893 }
5894 current_file = CB_FILE (cb_ref ($2));
5895 current_file->description_entry = $2;
5896 if (CB_VALID_TREE (current_file)) {
5897 if ($1 == cb_int1) {
5898 current_file->organization = COB_ORG_SORT;
5899 }
5900 /* note: this is a HACK and should be moved */
5901 if (current_file->flag_finalized) {
5902 cb_error_x ($2, _("duplicate file description for %s"),
5903 cb_name (CB_TREE (current_file)));
5904 }
5905 }
5906 }
5907 _file_description_clause_sequence TOK_DOT
5908 | file_type error TOK_DOT
5909 {
5910 yyerrok;
5911 }
5912 ;
5913
5914 file_type:
5915 FD
5916 {
5917 $$ = cb_int0;
5918 }
5919 | SD
5920 {
5921 $$ = cb_int1;
5922 }
5923 ;
5924
5925 _file_description_clause_sequence:
5926 | _file_description_clause_sequence file_description_clause
5927 ;
5928
5929 file_description_clause:
5930 _is EXTERNAL
5931 {
5932 check_repeated ("EXTERNAL", SYN_CLAUSE_1, &check_duplicate);
5933 #if 0 /* RXWRXW - Global/External */
5934 if (current_file->flag_global) {
5935 cb_error (_("file cannot have both EXTERNAL and GLOBAL clauses"));
5936 }
5937 #endif
5938 current_file->flag_external = 1;
5939 }
5940 | _is GLOBAL
5941 {
5942 check_repeated ("GLOBAL", SYN_CLAUSE_2, &check_duplicate);
5943 #if 0 /* RXWRXW - Global/External */
5944 if (current_file->flag_external) {
5945 cb_error (_("file cannot have both EXTERNAL and GLOBAL clauses"));
5946 }
5947 #endif
5948 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
5949 cb_error (_("%s is invalid in a user FUNCTION"), "GLOBAL");
5950 } else {
5951 current_file->flag_global = 1;
5952 current_program->flag_file_global = 1;
5953 }
5954 }
5955 | block_contains_clause
5956 | record_clause
5957 | label_records_clause
5958 | value_of_clause
5959 | data_records_clause
5960 | linage_clause
5961 | recording_mode_clause
5962 | code_set_clause
5963 | report_clause
5964 ;
5965
5966
5967 /* BLOCK CONTAINS clause */
5968
5969 block_contains_clause:
5970 BLOCK _contains integer _to_integer _records_or_characters
5971 {
5972 check_repeated ("BLOCK", SYN_CLAUSE_3, &check_duplicate);
5973 /* ignore */
5974 }
5975 ;
5976
5977 _records_or_characters: | RECORDS | CHARACTERS ;
5978
5979
5980 /* RECORD clause */
5981
5982 record_clause:
5983 RECORD _contains integer _characters
5984 {
5985 check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate);
5986 if (current_file->organization == COB_ORG_LINE_SEQUENTIAL) {
5987 cb_warning (cb_warn_additional, _("RECORD clause ignored for LINE SEQUENTIAL"));
5988 } else {
5989 set_record_size (NULL, $3);
5990 }
5991 }
5992 | RECORD _contains integer TO integer _characters
5993 {
5994 check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate);
5995 if (current_file->organization == COB_ORG_LINE_SEQUENTIAL) {
5996 cb_warning (cb_warn_additional, _("RECORD clause ignored for LINE SEQUENTIAL"));
5997 } else {
5998 set_record_size ($3, $5);
5999 }
6000 }
6001 | RECORD _is VARYING _in _size _from_integer _to_integer _characters
6002 _record_depending
6003 {
6004 check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate);
6005 set_record_size ($6, $7);
6006 current_file->flag_check_record_varying_limits =
6007 current_file->record_min == 0 || current_file->record_max == 0;
6008 }
6009 ;
6010
6011 _record_depending:
6012 | DEPENDING _on reference
6013 {
6014 current_file->record_depending = $3;
6015 }
6016 ;
6017
6018 _from_integer:
6019 /* empty */ { $$ = NULL; }
6020 | _from integer { $$ = $2; }
6021 ;
6022
6023 _to_integer:
6024 /* empty */ { $$ = NULL; }
6025 | TO integer { $$ = $2; }
6026 ;
6027
6028
6029 /* LABEL RECORDS clause */
6030
6031 label_records_clause:
6032 LABEL records label_option
6033 {
6034 check_repeated ("LABEL", SYN_CLAUSE_5, &check_duplicate);
6035 cb_verify (cb_label_records_clause, "LABEL RECORDS");
6036 }
6037 ;
6038
6039
6040 /* VALUE OF clause */
6041
6042 value_of_clause:
6043 VALUE OF file_id _is valueof_name
6044 {
6045 check_repeated ("VALUE OF", SYN_CLAUSE_6, &check_duplicate);
6046 cb_verify (cb_value_of_clause, "VALUE OF");
6047 }
6048 | VALUE OF FILE_ID _is valueof_name
6049 {
6050 check_repeated ("VALUE OF", SYN_CLAUSE_6, &check_duplicate);
6051 cb_verify (cb_value_of_clause, "VALUE OF");
6052 if (!current_file->assign) {
6053 current_file->assign = cb_build_assignment_name (current_file, $5);
6054 }
6055 }
6056 ;
6057
6058 file_id:
6059 WORD
6060 | ID
6061 ;
6062
6063 valueof_name:
6064 LITERAL
6065 | qualified_word
6066 ;
6067
6068 /* DATA RECORDS clause */
6069
6070 data_records_clause:
6071 DATA records optional_reference_list
6072 {
6073 check_repeated ("DATA", SYN_CLAUSE_7, &check_duplicate);
6074 cb_verify (cb_data_records_clause, "DATA RECORDS");
6075 }
6076 ;
6077
6078
6079 /* LINAGE clause */
6080
6081 linage_clause:
6082 LINAGE _is reference_or_literal _lines
6083 _linage_sequence
6084 {
6085 check_repeated ("LINAGE", SYN_CLAUSE_8, &check_duplicate);
6086 if (current_file->organization != COB_ORG_LINE_SEQUENTIAL &&
6087 current_file->organization != COB_ORG_SEQUENTIAL) {
6088 cb_error (_("LINAGE clause with wrong file type"));
6089 } else {
6090 current_file->linage = $3;
6091 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
6092 if (current_linage == 0) {
6093 linage_file = current_file;
6094 }
6095 current_linage++;
6096 }
6097 }
6098 ;
6099
6100 _linage_sequence:
6101 | _linage_sequence linage_lines
6102 ;
6103
6104 linage_lines:
6105 linage_footing
6106 | linage_top
6107 | linage_bottom
6108 ;
6109
6110 linage_footing:
6111 _with FOOTING _at reference_or_literal
6112 {
6113 current_file->latfoot = $4;
6114 }
6115 ;
6116
6117 linage_top:
6118 TOP reference_or_literal
6119 {
6120 current_file->lattop = $2;
6121 }
6122 ;
6123
6124 linage_bottom:
6125 BOTTOM reference_or_literal
6126 {
6127 current_file->latbot = $2;
6128 }
6129 ;
6130
6131 /* RECORDING MODE clause */
6132
6133 recording_mode_clause:
6134 RECORDING _mode _is recording_mode
6135 {
6136 cobc_cs_check ^= CB_CS_RECORDING;
6137 check_repeated ("RECORDING", SYN_CLAUSE_9, &check_duplicate);
6138 /* ignore */
6139 }
6140 ;
6141
6142 recording_mode:
6143 F
6144 | V
6145 | FIXED
6146 | VARIABLE
6147 | u_or_s
6148 {
6149 if (current_file->organization != COB_ORG_SEQUENTIAL) {
6150 cb_error (_("RECORDING MODE U or S can only be used with RECORD SEQUENTIAL files"));
6151 }
6152 }
6153 ;
6154
6155 u_or_s:
6156 U
6157 | S
6158 ;
6159
6160 /* CODE-SET clause */
6161
6162 code_set_clause:
6163 CODE_SET _is alphabet_name _for_sub_records_clause
6164 {
6165 struct cb_alphabet_name *al;
6166
6167 check_repeated ("CODE SET", SYN_CLAUSE_10, &check_duplicate);
6168
6169 if (CB_VALID_TREE ($3)) {
6170 al = CB_ALPHABET_NAME (cb_ref ($3));
6171 switch (al->alphabet_type) {
6172 #ifdef COB_EBCDIC_MACHINE
6173 case CB_ALPHABET_ASCII:
6174 #else
6175 case CB_ALPHABET_EBCDIC:
6176 #endif
6177 case CB_ALPHABET_CUSTOM:
6178 current_file->code_set = al;
6179 CB_PENDING ("CODE-SET");
6180 break;
6181 default:
6182 if (cb_warn_opt_val[cb_warn_additional] != COBC_WARN_DISABLED) {
6183 cb_warning_x (cb_warn_additional, $3, _("ignoring CODE-SET '%s'"),
6184 cb_name ($3));
6185 } else {
6186 CB_PENDING ("CODE-SET");
6187 }
6188 break;
6189 }
6190 }
6191
6192 if (current_file->organization != COB_ORG_LINE_SEQUENTIAL &&
6193 current_file->organization != COB_ORG_SEQUENTIAL) {
6194 cb_error (_("CODE-SET clause invalid for file type"));
6195 }
6196
6197 }
6198 ;
6199
6200 _for_sub_records_clause:
6201 | FOR reference_list
6202 {
6203 CB_PENDING ("FOR sub-records");
6204 current_file->code_set_items = CB_LIST ($2);
6205 }
6206 ;
6207
6208 /* REPORT clause */
6209
6210 report_clause:
6211 report_keyword rep_name_list
6212 {
6213 check_repeated ("REPORT", SYN_CLAUSE_11, &check_duplicate);
6214 if (current_file->organization != COB_ORG_LINE_SEQUENTIAL &&
6215 current_file->organization != COB_ORG_SEQUENTIAL) {
6216 cb_error (_("REPORT clause with wrong file type"));
6217 } else {
6218 current_file->reports = $2;
6219 current_file->organization = COB_ORG_LINE_SEQUENTIAL;
6220 current_file->flag_line_adv = 1;
6221 }
6222 }
6223 ;
6224
6225 report_keyword:
6226 REPORT _is
6227 | REPORTS _are
6228 ;
6229
6230 rep_name_list:
6231 undefined_word
6232 {
6233 if (CB_VALID_TREE ($1)) {
6234 current_report = build_report ($1);
6235 current_report->file = current_file;
6236 current_program->report_list =
6237 cb_list_add (current_program->report_list,
6238 CB_TREE (current_report));
6239 if (report_count == 0) {
6240 report_instance = current_report;
6241 }
6242 report_count++;
6243 }
6244 }
6245 | rep_name_list undefined_word
6246 {
6247 if (CB_VALID_TREE ($2)) {
6248 current_report = build_report ($2);
6249 current_report->file = current_file;
6250 current_program->report_list =
6251 cb_list_add (current_program->report_list,
6252 CB_TREE (current_report));
6253 if (report_count == 0) {
6254 report_instance = current_report;
6255 }
6256 report_count++;
6257 }
6258 }
6259 ;
6260
6261 /* COMMUNICATION SECTION */
6262
6263 _communication_section:
6264 | COMMUNICATION SECTION TOK_DOT
6265 {
6266 current_storage = CB_STORAGE_COMMUNICATION;
6267 check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
6268 header_check |= COBC_HD_COMMUNICATION_SECTION;
6269 /* add a compiler configuration if either */
6270 if (cb_std_define != CB_STD_85
6271 && cb_std_define != CB_STD_RM
6272 && cb_std_define != CB_STD_GC
6273 && !cb_relaxed_syntax_checks) {
6274 cb_verify (CB_UNCONFORMABLE, "COMMUNICATION SECTION");
6275 } else if (cb_verify (CB_OBSOLETE, "COMMUNICATION SECTION")) {
6276 CB_PENDING ("COMMUNICATION SECTION");
6277 }
6278 }
6279 _communication_description_sequence
6280 ;
6281
6282 _communication_description_sequence:
6283 | _communication_description_sequence communication_description
6284 ;
6285
6286 communication_description:
6287 communication_description_entry
6288 _record_description_list
6289 {
6290 if (CB_VALID_TREE (current_cd)) {
6291 if (CB_VALID_TREE ($2)) {
6292 cb_finalize_cd (current_cd, CB_FIELD ($2));
6293 } else if (!current_cd->record) {
6294 cb_error (_("CD record missing"));
6295 }
6296 }
6297 }
6298 ;
6299
6300 /* File description entry */
6301
6302 communication_description_entry:
6303 CD undefined_word
6304 {
6305 /* CD internally defines a new file */
6306 if (CB_VALID_TREE ($2)) {
6307 current_cd = cb_build_cd ($2);
6308
6309 CB_ADD_TO_CHAIN (CB_TREE (current_cd),
6310 current_program->cd_list);
6311 } else {
6312 current_cd = NULL;
6313 /* TO-DO: Is this necessary? */
6314 if (current_program->cd_list) {
6315 current_program->cd_list
6316 = CB_CHAIN (current_program->cd_list);
6317 }
6318 }
6319 check_duplicate = 0;
6320 }
6321 _communication_description_clause_sequence TOK_DOT
6322 ;
6323
6324 _communication_description_clause_sequence:
6325 | _communication_description_clause_sequence communication_description_clause
6326 ;
6327
6328 communication_description_clause:
6329 _for _initial INPUT _input_cd_clauses
6330 | _for OUTPUT _output_cd_clauses
6331 | _for _initial I_O _i_o_cd_clauses
6332 ;
6333
6334 _input_cd_clauses:
6335 /* empty */
6336 | named_input_cd_clauses
6337 | unnamed_input_cd_clauses
6338 ;
6339
6340 named_input_cd_clauses:
6341 named_input_cd_clause
6342 | named_input_cd_clauses named_input_cd_clause
6343 ;
6344
6345 named_input_cd_clause:
6346 _symbolic QUEUE _is identifier
6347 | _symbolic SUB_QUEUE_1 _is identifier
6348 | _symbolic SUB_QUEUE_2 _is identifier
6349 | _symbolic SUB_QUEUE_3 _is identifier
6350 | MESSAGE DATE _is identifier
6351 | MESSAGE TIME _is identifier
6352 | _symbolic SOURCE _is identifier
6353 | TEXT LENGTH _is identifier
6354 | END KEY _is identifier
6355 | STATUS KEY _is identifier
6356 | _message COUNT _is identifier
6357 ;
6358
6359 unnamed_input_cd_clauses:
6360 identifier identifier identifier identifier identifier identifier identifier
6361 identifier identifier identifier identifier
6362 ;
6363
6364 _output_cd_clauses:
6365 /* empty */
6366 | output_cd_clauses
6367 ;
6368
6369 output_cd_clauses:
6370 output_cd_clause
6371 | output_cd_clauses output_cd_clause
6372 ;
6373
6374 output_cd_clause:
6375 DESTINATION COUNT _is identifier
6376 | TEXT LENGTH _is identifier
6377 | STATUS KEY _is identifier
6378 | DESTINATION TABLE OCCURS integer _times _occurs_indexed
6379 | ERROR KEY _is identifier
6380 | DESTINATION _is identifier
6381 | SYMBOLIC DESTINATION _is identifier
6382 ;
6383
6384 _i_o_cd_clauses:
6385 /* empty */
6386 | named_i_o_cd_clauses
6387 | unnamed_i_o_cd_clauses
6388 ;
6389
6390 named_i_o_cd_clauses:
6391 named_i_o_cd_clause
6392 | named_i_o_cd_clauses named_i_o_cd_clause
6393 ;
6394
6395 named_i_o_cd_clause:
6396 MESSAGE DATE _is identifier
6397 | MESSAGE TIME _is identifier
6398 | _symbolic TERMINAL _is identifier
6399 | TEXT LENGTH _is identifier
6400 | END KEY _is identifier
6401 | STATUS KEY _is identifier
6402 ;
6403
6404 unnamed_i_o_cd_clauses:
6405 identifier identifier identifier identifier identifier identifier
6406 ;
6407
6408 /* WORKING-STORAGE SECTION */
6409
6410 _working_storage_section:
6411 | WORKING_STORAGE SECTION TOK_DOT
6412 {
6413 check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
6414 header_check |= COBC_HD_WORKING_STORAGE_SECTION;
6415 current_storage = CB_STORAGE_WORKING;
6416 }
6417 _record_description_list
6418 {
6419 if ($5) {
6420 CB_FIELD_ADD (current_program->working_storage, CB_FIELD ($5));
6421 }
6422 }
6423 ;
6424
6425 _record_description_list:
6426 /* empty */
6427 {
6428 $$ = NULL;
6429 }
6430 |
6431 {
6432 current_field = NULL;
6433 control_field = NULL;
6434 description_field = NULL;
6435 cb_clear_real_field ();
6436 }
6437 record_description_list
6438 {
6439 $$ = get_finalized_description_tree ();
6440 }
6441 ;
6442
6443 record_description_list:
6444 data_description TOK_DOT
6445 | record_description_list data_description TOK_DOT
6446 ;
6447
6448 data_description:
6449 constant_entry
6450 | renames_entry
6451 | condition_name_entry
6452 | level_number _entry_name
6453 {
6454 if (current_field && !CB_INVALID_TREE (current_field->external_definition)) {
6455 /* finalize last field if target of SAME AS / type-name */
6456 inherit_external_definition ($1);
6457 }
6458 if (set_current_field ($1, $2)) {
6459 YYERROR;
6460 }
6461 save_tree = NULL;
6462 }
6463 _data_description_clause_sequence
6464 {
6465 if (!qualifier) {
6466 current_field->flag_filler = 1;
6467 }
6468 if (!description_field) {
6469 description_field = current_field;
6470 }
6471 }
6472 | level_number error TOK_DOT
6473 {
6474 #if 0 /* works fine without, leads to invalid free otherwise [COB_TREE_DEBUG] */
6475 /* Free tree associated with level number */
6476 cobc_parse_free ($1);
6477 #endif
6478 yyerrok;
6479 cb_unput_dot ();
6480 check_pic_duplicate = 0;
6481 check_duplicate = 0;
6482 #if 0 /* CHECKME - *Why* would we want to change the field here? */
6483 current_field = cb_get_real_field ();
6484 #endif
6485 }
6486 ;
6487
6488 level_number:
6489 not_const_word LEVEL_NUMBER
6490 {
6491 $$ = $2;
6492 }
6493 ;
6494
6495 _filler:
6496 /* empty */
6497 | FILLER
6498 ;
6499
6500 _entry_name:
6501 _filler
6502 {
6503 $$ = cb_build_filler ();
6504 qualifier = NULL;
6505 keys_list = NULL;
6506 non_const_word = 0;
6507 }
6508 | user_entry_name
6509 ;
6510
6511 user_entry_name:
6512 WORD
6513 {
6514 $$ = $1;
6515 qualifier = $1;
6516 keys_list = NULL;
6517 non_const_word = 0;
6518 }
6519 ;
6520
6521 _const_global:
6522 /* Nothing */
6523 {
6524 $$ = NULL;
6525 }
6526 | _is GLOBAL
6527 {
6528 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
6529 cb_error (_("%s is invalid in a user FUNCTION"), "GLOBAL");
6530 $$ = NULL;
6531 } else {
6532 $$ = cb_null;
6533 }
6534 }
6535 ;
6536
6537 lit_or_length:
6538 literal { $$ = $1; }
6539 | length_of_register con_source { $$ = cb_build_const_length ($2); }
6540 /* note: only reserved in context of CB_CS_CONSTANT: */
6541 | BYTE_LENGTH _of con_source { $$ = cb_build_const_length ($3); }
6542 ;
6543
6544 con_source:
6545 identifier_1
6546 {
6547 $$ = $1;
6548 }
6549 | non_numeric_literal
6550 {
6551 $$ = $1;
6552 }
6553 /* note: all entries below are non-standard GnuCOBOL only extensions
6554 (and miss the newer fixed-length USAGE types) */
6555 | BINARY_CHAR
6556 {
6557 $$ = cb_int1;
6558 }
6559 | BINARY_SHORT
6560 {
6561 $$ = cb_int2;
6562 }
6563 | BINARY_LONG
6564 {
6565 $$ = cb_int4;
6566 }
6567 | BINARY_DOUBLE
6568 {
6569 $$ = cb_int8;
6570 }
6571 | BINARY_C_LONG
6572 {
6573 $$ = cb_int ((int)sizeof(long));
6574 }
6575 | pointer_len
6576 {
6577 $$ = cb_int ((int)sizeof(void *));
6578 }
6579 | COMP_1
6580 {
6581 if (cb_binary_comp_1) {
6582 $$ = cb_int2;
6583 } else {
6584 $$ = cb_int ((int)sizeof(float));
6585 }
6586 }
6587 | FLOAT_SHORT /* alias from FLOAT (ACU) in reserved.c */
6588 {
6589 $$ = cb_int ((int)sizeof(float));
6590 }
6591 | double_usage
6592 {
6593 $$ = cb_int ((int)sizeof(double));
6594 }
6595 | fp32_usage
6596 {
6597 $$ = cb_int4;
6598 }
6599 | fp64_usage
6600 {
6601 $$ = cb_int8;
6602 }
6603 | fp128_usage
6604 {
6605 $$ = cb_int16;
6606 }
6607 | error TOK_DOT
6608 {
6609 yyerrok;
6610 cb_unput_dot ();
6611 check_pic_duplicate = 0;
6612 check_duplicate = 0;
6613 current_field = cb_get_real_field ();
6614 }
6615 ;
6616
6617 fp32_usage:
6618 FLOAT_BINARY_32
6619 | FLOAT_DECIMAL_7
6620 ;
6621
6622 fp64_usage:
6623 FLOAT_BINARY_64
6624 | FLOAT_DECIMAL_16
6625 ;
6626
6627 fp128_usage:
6628 FLOAT_BINARY_128
6629 | FLOAT_DECIMAL_34
6630 | FLOAT_EXTENDED
6631 ;
6632
6633 pointer_len:
6634 POINTER
6635 | PROGRAM_POINTER
6636 ;
6637
6638 renames_entry:
6639 SIXTY_SIX user_entry_name RENAMES not_const_word qualified_word _renames_thru
6640 {
6641 cb_tree renames_target = cb_ref ($5);
6642
6643 size_t sav = cb_needs_01;
6644 cb_needs_01 = 0;
6645
6646 non_const_word = 0;
6647
6648 if (set_current_field ($1, $2)) {
6649 /* error in the definition, no further checks possible */
6650 } else if (renames_target == cb_error_node) {
6651 /* error in the target, skip further checks */
6652 current_field->flag_invalid = 1;
6653 } else {
6654 cb_tree renames_thru = $6;
6655
6656 current_field->redefines = CB_FIELD (renames_target);
6657 if (renames_thru) {
6658 renames_thru = cb_ref (renames_thru);
6659 }
6660 if (CB_VALID_TREE (renames_thru)) {
6661 current_field->rename_thru = CB_FIELD (renames_thru);
6662 } else {
6663 /* If there is no THRU clause, RENAMES acts like REDEFINES. */
6664 current_field->pic = current_field->redefines->pic;
6665 }
6666
6667 if (cb_validate_renames_item (current_field, $5, $6)) {
6668 current_field->flag_invalid = 1;
6669 } else {
6670 /* ensure the reference was validated as this
6671 also calculates the reference' picture and size */
6672 if (!current_field->redefines->flag_is_verified) {
6673 cb_validate_field (current_field->redefines);
6674 }
6675 }
6676 }
6677 cb_needs_01 = sav;
6678 }
6679 ;
6680
6681 _renames_thru:
6682 /* empty */
6683 {
6684 $$ = NULL;
6685 }
6686 | THRU qualified_word
6687 {
6688 $$ = $2 == cb_error_node ? NULL : $2;
6689 }
6690 ;
6691
6692 condition_name_entry:
6693 EIGHTY_EIGHT user_entry_name
6694 {
6695 if (set_current_field ($1, $2)) {
6696 YYERROR;
6697 }
6698 }
6699 value_clause
6700 {
6701 cb_validate_88_item (current_field);
6702 }
6703 ;
6704
6705 constant_entry:
6706 level_number user_entry_name CONSTANT _const_global constant_source
6707 {
6708 cb_tree x;
6709 int level;
6710
6711 cobc_cs_check = 0;
6712 level = cb_get_level ($1);
6713 /* Free tree associated with level number */
6714 cobc_parse_free ($1);
6715 if (level != 1) {
6716 cb_error (_("CONSTANT item not at 01 level"));
6717 } else if ($5) {
6718 if (cb_verify(cb_constant_01, "01 CONSTANT")) {
6719 x = cb_build_constant ($2, $5);
6720 CB_FIELD (x)->flag_item_78 = 1;
6721 CB_FIELD (x)->flag_constant = 1;
6722 CB_FIELD (x)->level = 1;
6723 CB_FIELD (x)->values = $5;
6724 cb_needs_01 = 1;
6725 if ($4) {
6726 CB_FIELD (x)->flag_is_global = 1;
6727 }
6728 /* Ignore return value */
6729 (void)cb_validate_78_item (CB_FIELD (x), 0);
6730 }
6731 }
6732 }
6733 | SEVENTY_EIGHT user_entry_name
6734 {
6735 if (set_current_field ($1, $2)) {
6736 YYERROR;
6737 }
6738 }
6739 _global_clause
6740 VALUE _is constant_78_source
6741 {
6742 /* Reset to last non-78 item */
6743 current_field = cb_validate_78_item (current_field, 0);
6744 }
6745 ;
6746
6747 constant_source:
6748 _as value_item_list
6749 {
6750 $$ = $2;
6751 }
6752 | FROM WORD
6753 {
6754 $$ = CB_LIST_INIT(cb_build_const_from ($2));
6755 }
6756 ;
6757
6758 constant_78_source:
6759 constant_expression_list
6760 {
6761 if (CB_VALID_TREE (current_field)) {
6762 current_field->values = $1;
6763 }
6764 }
6765 | START _of identifier
6766 {
6767 current_field->values = CB_LIST_INIT (cb_build_const_start (current_field, $3));
6768 }
6769 | NEXT
6770 {
6771 current_field->values = CB_LIST_INIT (cb_build_const_next (current_field));
6772 }
6773 ;
6774
6775 constant_expression_list:
6776 constant_expression { $$ = CB_LIST_INIT ($1); }
6777 | constant_expression_list constant_expression { $$ = cb_list_add ($1, $2); }
6778 ;
6779
6780 constant_expression:
6781 lit_or_length { $$ = $1; }
6782 | TOK_OPEN_PAREN { $$ = cb_build_alphanumeric_literal ("(", 1); }
6783 | TOK_CLOSE_PAREN { $$ = cb_build_alphanumeric_literal (")", 1); }
6784 | TOK_PLUS { $$ = cb_build_alphanumeric_literal ("+", 1); }
6785 | TOK_MINUS { $$ = cb_build_alphanumeric_literal ("-", 1); }
6786 | TOK_MUL { $$ = cb_build_alphanumeric_literal ("*", 1); }
6787 | TOK_DIV { $$ = cb_build_alphanumeric_literal ("/", 1); }
6788 | AND { $$ = cb_build_alphanumeric_literal ("&", 1); }
6789 | OR { $$ = cb_build_alphanumeric_literal ("|", 1); }
6790 | EXPONENTIATION { $$ = cb_build_alphanumeric_literal ("^", 1); }
6791 ;
6792
6793 _data_description_clause_sequence:
6794 /* empty */
6795 | data_description_clause_sequence
6796 ;
6797
6798 data_description_clause_sequence:
6799 data_description_clause
6800 {
6801 save_tree = cb_int0;
6802 }
6803 | data_description_clause_sequence data_description_clause
6804 ;
6805
6806 data_description_clause:
6807 redefines_clause
6808 | same_as_clause
6809 | typedef_clause
6810 | like_clause
6811 | external_clause
6812 | special_names_clause
6813 | global_clause
6814 | picture_clause
6815 | usage_clause
6816 | type_to_clause
6817 | sign_clause
6818 | occurs_clause
6819 | justified_clause
6820 | synchronized_clause
6821 | blank_clause
6822 | based_clause
6823 | value_clause
6824 | any_length_clause
6825 | external_form_clause
6826 | identified_by_clause
6827 | volatile_clause
6828 ;
6829
6830
6831 /* REDEFINES clause */
6832
6833 redefines_clause:
6834 REDEFINES identifier_1
6835 {
6836 check_repeated ("REDEFINES", SYN_CLAUSE_1, &check_pic_duplicate);
6837 if (save_tree != NULL) {
6838 cb_verify_x ($2, cb_free_redefines_position,
6839 _("REDEFINES clause not following entry-name"));
6840 }
6841
6842 current_field->redefines = cb_resolve_redefines (current_field, $2);
6843 if (current_field->redefines == NULL) {
6844 current_field->flag_is_verified = 1;
6845 current_field->flag_invalid = 1;
6846 YYERROR;
6847 }
6848 }
6849 ;
6850
6851
6852 /* LIKE clause (ILE extension) */
6853
6854 like_clause:
6855 LIKE identifier_field _length_modifier
6856 {
6857 if (!check_repeated ("LIKE", SYN_CLAUSE_30, &check_pic_duplicate)) {
6858 if (current_field->external_definition) {
6859 emit_conflicting_clause_message ("TYPE TO", "SAME AS");
6860 }
6861 setup_external_definition ($2, 0);
6862 current_field->like_modifier = $3;
6863 CB_PENDING_X ($2, "LIKE clause");
6864 }
6865 }
6866 ;
6867
6868 _length_modifier:
6869 /* empty */ { $$ = cb_int0; }
6870 | length_modifier;
6871
6872 length_modifier:
6873 TOK_OPEN_PAREN nonzero_numeric_literal TOK_CLOSE_PAREN
6874 {
6875 $$ = $2;
6876 }
6877 ;
6878
6879 /* SAME AS clause ("AS" optional with RM-COBOL, not with COBOL2002+) */
6880
6881 same_as_clause:
6882 SAME _as identifier_field
6883 {
6884 if (!check_repeated ("SAME AS", SYN_CLAUSE_30, &check_pic_duplicate)) {
6885 if (current_field->external_definition) {
6886 emit_conflicting_clause_message ("TYPE TO", "SAME AS");
6887 }
6888 cb_verify (cb_same_as_clause, _("SAME AS clause"));
6889 setup_external_definition ($3, 0);
6890 }
6891
6892
6893 }
6894 ;
6895
6896
6897 /* TYPEDEF clause (COBOL2002+ rule "directly after entry-name" ignored [not true for MF!]) */
6898
6899 typedef_clause:
6900 _is TYPEDEF _strong
6901 {
6902 if (current_field->flag_is_typedef) {
6903 emit_duplicate_clause_message ("TYPEDEF");
6904 YYERROR;
6905 }
6906 /* note: no explicit verification as all dialects with this reserved word use it */
6907 current_field->flag_is_typedef = 1;
6908 within_typedef_definition = 1;
6909
6910 if (current_field->level != 1 && current_field->level != 77) {
6911 cb_error (_("%s only allowed at 01/77 level"), "TYPEDEF");
6912 }
6913 if (!qualifier) {
6914 cb_error (_("%s requires a data name"), "TYPEDEF");
6915 }
6916 if (current_storage == CB_STORAGE_SCREEN
6917 || current_storage == CB_STORAGE_REPORT) {
6918 cb_error (_("%s not allowed in %s"), "TYPEDEF",
6919 enum_explain_storage(current_storage));
6920 }
6921 }
6922 ;
6923
6924 _strong:
6925 | STRONG
6926 {
6927 CB_PENDING ("TYPEDEF STRONG");
6928 }
6929 ;
6930
6931
6932 /* EXTERNAL clause */
6933
6934 external_clause:
6935 _is EXTERNAL _as_extname
6936 {
6937 check_repeated ("EXTERNAL", SYN_CLAUSE_2, &check_pic_duplicate);
6938 if (current_storage != CB_STORAGE_WORKING) {
6939 cb_error (_("%s not allowed here"), "EXTERNAL");
6940 } else if (current_field->level != 1 && current_field->level != 77) {
6941 cb_error (_("%s only allowed at 01/77 level"), "EXTERNAL");
6942 } else if (!qualifier) {
6943 cb_error (_("%s requires a data name"), "EXTERNAL");
6944 #if 0 /* RXWRXW - Global/External */
6945 } else if (current_field->flag_is_global) {
6946 cb_error (_("%s and %s are mutually exclusive"), "GLOBAL", "EXTERNAL");
6947 #endif
6948 } else if (current_field->flag_item_based) {
6949 cb_error (_("%s and %s are mutually exclusive"), "BASED", "EXTERNAL");
6950 } else if (current_field->redefines) {
6951 cb_error (_("%s and %s are mutually exclusive"), "EXTERNAL", "REDEFINES");
6952 } else if (current_field->flag_occurs) {
6953 cb_error (_("%s and %s are mutually exclusive"), "EXTERNAL", "OCCURS");
6954 } else {
6955 current_field->flag_external = 1;
6956 current_program->flag_has_external = 1;
6957 }
6958 }
6959 ;
6960
6961 _as_extname:
6962 /* empty */
6963 {
6964 current_field->ename = cb_to_cname (current_field->name);
6965 }
6966 | AS LITERAL
6967 {
6968 current_field->ename = cb_to_cname ((const char *)CB_LITERAL ($2)->data);
6969 }
6970 ;
6971
6972 /* GLOBAL clause */
6973
6974 _global_clause:
6975 | global_clause
6976 ;
6977
6978 global_clause:
6979 _is GLOBAL
6980 {
6981 check_repeated ("GLOBAL", SYN_CLAUSE_3, &check_pic_duplicate);
6982 if (current_field->level != 1 && current_field->level != 77) {
6983 cb_error (_("%s only allowed at 01/77 level"), "GLOBAL");
6984 } else if (!qualifier) {
6985 cb_error (_("%s requires a data name"), "GLOBAL");
6986 #if 0 /* RXWRXW - Global/External */
6987 } else if (current_field->flag_external) {
6988 cb_error (_("%s and %s are mutually exclusive"), "GLOBAL", "EXTERNAL");
6989 #endif
6990 } else if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
6991 cb_error (_("%s is invalid in a user FUNCTION"), "GLOBAL");
6992 } else if (current_storage == CB_STORAGE_LOCAL) {
6993 cb_error (_("%s not allowed here"), "GLOBAL");
6994 } else {
6995 current_field->flag_is_global = 1;
6996 }
6997 }
6998 ;
6999
7000 /* SPECIAL-NAMES clause */
7001
7002 special_names_clause:
7003 _is SPECIAL_NAMES
7004 {
7005 if (current_program->nested_level) {
7006 cb_error (_("%s not allowed in nested programs"), "SPECIAL-NAMES");
7007 } else {
7008 cb_verify (cb_special_names_clause, "SPECIAL-NAMES clause");
7009 }
7010 }
7011 special_names_target
7012 ;
7013
7014 special_names_target:
7015 CURSOR
7016 {
7017 if (current_program->cursor_pos) {
7018 emit_duplicate_clause_message ("CURSOR");
7019 } else {
7020 current_program->cursor_pos = cb_build_reference (current_field->name);
7021 }
7022 }
7023 | CRT STATUS
7024 {
7025 if (current_program->crt_status) {
7026 emit_duplicate_clause_message ("CRT STATUS");
7027 } else {
7028 current_program->crt_status = cb_build_reference (current_field->name);
7029 }
7030 }
7031 /* not included, possibly never will
7032 | CHART STATUS
7033 {
7034 if (current_program->chart_status) {
7035 emit_duplicate_clause_message ("CHART STATUS");
7036 } else {
7037 current_program->chart_status = cb_build_reference (current_field->name);
7038 }
7039 } */
7040 | SCREEN_CONTROL
7041 {
7042 #if 0 /* not yet implemented */
7043 if (current_program->screen_control) {
7044 emit_duplicate_clause_message ("SCREEN CONTROL");
7045 } else {
7046 CB_PENDING ("SCREEN CONTROL");
7047 }
7048 #else
7049 CB_PENDING ("SCREEN CONTROL");
7050 #endif
7051 }
7052 | EVENT_STATUS
7053 {
7054 #if 0 /* not yet implemented */
7055 if (current_program->event_status) {
7056 emit_duplicate_clause_message ("EVENT STATUS");
7057 } else {
7058 CB_PENDING ("EVENT STATUS");
7059 }
7060 #else
7061 CB_PENDING ("EVENT STATUS");
7062 #endif
7063 }
7064 ;
7065
7066 /* VOLATILE clause */
7067
7068 volatile_clause:
7069 VOLATILE
7070 {
7071 check_repeated ("VOLATILE", SYN_CLAUSE_24, &check_pic_duplicate);
7072 /* note: there is no reason to check current_storage as we only parse
7073 volatile_clause and its parent tokens where applicable,
7074 same is true for level 66,78,88 */
7075 /* missing part: always generate and initialize storage */
7076 CB_UNFINISHED ("VOLATILE");
7077 current_field->flag_volatile = 1;
7078 /* TODO: set VOLATILE flag for all parent fields */
7079 }
7080 ;
7081
7082
7083 /* PICTURE clause */
7084
7085 picture_clause:
7086 PICTURE /* token from scanner, includes full picture definition */
7087 _pic_locale_format
7088 {
7089 check_repeated ("PICTURE", SYN_CLAUSE_4, &check_pic_duplicate);
7090 current_field->pic = CB_PICTURE ($1);
7091
7092 if (CB_VALID_TREE ($2)) {
7093 if ( (current_field->pic->category != CB_CATEGORY_NUMERIC
7094 && current_field->pic->category != CB_CATEGORY_NUMERIC_EDITED)
7095 || strpbrk (current_field->pic->orig, " CRDB-*") /* the standard seems to forbid also ',' */) {
7096 cb_error_x ($1, _("a locale-format PICTURE string must only consist of '9', '.', '+', 'Z' and the currency-sign"));
7097 } else {
7098 /* TODO: check that not we're not within a CONSTANT RECORD */
7099 CB_PENDING_X ($1, "locale-format PICTURE");
7100 }
7101 }
7102 }
7103 ;
7104
7105 _pic_locale_format:
7106 /* empty */
7107 { $$ = NULL; }
7108 | LOCALE _is_locale_name SIZE _is integer
7109 {
7110 /* $2 -> optional locale-name to be used */
7111 $$ = $5;
7112 }
7113 ;
7114
7115 _is_locale_name:
7116 /* empty */
7117 | _is locale_name
7118 {
7119 $$ = $2;
7120 }
7121 ;
7122
7123
7124 locale_name:
7125 WORD
7126 {
7127 if (CB_LOCALE_NAME_P (cb_ref ($1))) {
7128 $$ = $1;
7129 } else {
7130 cb_error_x ($1, _("'%s' is not a locale-name"), cb_name ($1));
7131 $$ = cb_error_node;
7132 }
7133 }
7134 ;
7135
7136
7137 /* TYPE TO clause, optional "TO", fixed to clean conflicts for screen-items */
7138
7139 type_to_clause:
7140 TYPE _to type_name
7141 {
7142 cb_verify (cb_type_to_clause, _("TYPE TO clause"));
7143 setup_external_definition_type ($3);
7144 }
7145 ;
7146
7147
7148 /* USAGE clause */
7149
7150 usage_clause:
7151 usage
7152 | USAGE _is usage
7153 | USAGE _is WORD
7154 {
7155 {
7156 cb_tree x = cb_try_ref ($3);
7157 if (!CB_INVALID_TREE (x) && CB_FIELD_P (x) && CB_FIELD (x)->flag_is_typedef) {
7158 if (!check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate)) {
7159 if (current_field->external_definition) {
7160 emit_conflicting_clause_message ("USAGE", "SAME AS / TYPE TO");
7161 } else {
7162 cb_verify (cb_usage_type_name, _("USAGE type-name"));
7163 /* replace usage by type definition */
7164 check_pic_duplicate &= ~SYN_CLAUSE_5;
7165 check_repeated ("USAGE/TYPE", SYN_CLAUSE_31, &check_pic_duplicate);
7166 setup_external_definition ($3, 1);
7167 break; /* everything done here */
7168 }
7169 }
7170 YYERROR;
7171 }
7172 }
7173 if (is_reserved_word (CB_NAME ($3))) {
7174 cb_error_x ($3, _("'%s' is not a valid USAGE"), CB_NAME ($3));
7175 } else if (is_default_reserved_word (CB_NAME ($3))) {
7176 cb_error_x ($3, _("'%s' is not defined, but is a reserved word in another dialect"),
7177 CB_NAME ($3));
7178 } else {
7179 cb_error_x ($3, _("unknown USAGE: %s"), CB_NAME ($3));
7180 }
7181 check_and_set_usage (CB_USAGE_ERROR);
7182 YYERROR;
7183 }
7184 | USAGE _is error
7185 {
7186 check_and_set_usage (CB_USAGE_ERROR);
7187 }
7188 ;
7189
7190 usage:
7191 BINARY
7192 {
7193 check_and_set_usage (CB_USAGE_BINARY);
7194 }
7195 | BIT
7196 {
7197 check_and_set_usage (CB_USAGE_BIT);
7198 CB_PENDING ("USAGE BIT");
7199 }
7200 | COMP
7201 {
7202 check_and_set_usage (CB_USAGE_BINARY);
7203 }
7204 | COMP_0
7205 {
7206 /* see FR #310 */
7207 CB_PENDING ("USAGE COMP-0");
7208 }
7209 | COMP_1
7210 {
7211 current_field->flag_comp_1 = 1;
7212 if (cb_binary_comp_1) {
7213 check_and_set_usage (CB_USAGE_SIGNED_SHORT);
7214 } else {
7215 check_and_set_usage (CB_USAGE_FLOAT);
7216 }
7217 }
7218 | double_usage
7219 {
7220 check_and_set_usage (CB_USAGE_DOUBLE);
7221 }
7222 | COMP_3
7223 {
7224 check_and_set_usage (CB_USAGE_PACKED);
7225 }
7226 | COMP_4
7227 {
7228 check_and_set_usage (CB_USAGE_BINARY);
7229 }
7230 | COMP_5
7231 {
7232 check_and_set_usage (CB_USAGE_COMP_5);
7233 }
7234 | COMP_6
7235 {
7236 check_and_set_usage (CB_USAGE_COMP_6);
7237 }
7238 | COMP_X
7239 {
7240 check_and_set_usage (CB_USAGE_COMP_X);
7241 }
7242 | COMP_N
7243 {
7244 check_and_set_usage (CB_USAGE_COMP_N);
7245 }
7246 | FLOAT_SHORT
7247 {
7248 check_and_set_usage (CB_USAGE_FLOAT);
7249 }
7250 | DISPLAY
7251 {
7252 check_and_set_usage (CB_USAGE_DISPLAY);
7253 }
7254 | INDEX
7255 {
7256 check_and_set_usage (CB_USAGE_INDEX);
7257 }
7258 | PACKED_DECIMAL
7259 {
7260 check_and_set_usage (CB_USAGE_PACKED);
7261 }
7262 | POINTER
7263 {
7264 check_and_set_usage (CB_USAGE_POINTER);
7265 current_field->flag_is_pointer = 1;
7266 }
7267 | PROGRAM_POINTER
7268 {
7269 check_and_set_usage (CB_USAGE_PROGRAM_POINTER);
7270 current_field->flag_is_pointer = 1;
7271 }
7272 | HANDLE
7273 {
7274 check_and_set_usage (CB_USAGE_HNDL);
7275 }
7276 | HANDLE _of WINDOW
7277 {
7278 check_and_set_usage (CB_USAGE_HNDL_WINDOW);
7279 }
7280 | HANDLE _of SUBWINDOW
7281 {
7282 check_and_set_usage (CB_USAGE_HNDL_SUBWINDOW);
7283 }
7284 | HANDLE _of FONT _font_name
7285 {
7286 check_and_set_usage (CB_USAGE_HNDL_FONT);
7287 CB_PENDING ("HANDLE OF FONT");
7288 }
7289 | HANDLE _of THREAD
7290 {
7291 check_and_set_usage (CB_USAGE_HNDL_THREAD);
7292 }
7293 | HANDLE _of MENU
7294 {
7295 check_and_set_usage (CB_USAGE_HNDL_MENU);
7296 CB_PENDING ("HANDLE OF MENU");
7297 }
7298 | HANDLE _of VARIANT
7299 {
7300 check_and_set_usage (CB_USAGE_HNDL_VARIANT);
7301 }
7302 | HANDLE _of LAYOUT_MANAGER _layout_name
7303 {
7304 check_and_set_usage (CB_USAGE_HNDL_LM);
7305 CB_PENDING ("HANDLE OF LAYOUT-MANAGER");
7306 }
7307 | HANDLE _of control_type_name
7308 {
7309 check_and_set_usage (CB_USAGE_HNDL);
7310 CB_PENDING ("HANDLE OF control-type");
7311 }
7312 | HANDLE _of WORD
7313 {
7314 check_and_set_usage (CB_USAGE_HNDL);
7315 cb_error_x ($3, _("unknown HANDLE type: %s"), CB_NAME ($3));
7316 }
7317 | SIGNED_SHORT
7318 {
7319 check_and_set_usage (CB_USAGE_SIGNED_SHORT);
7320 }
7321 | SIGNED_INT
7322 {
7323 check_and_set_usage (CB_USAGE_SIGNED_INT);
7324 }
7325 | SIGNED_LONG
7326 {
7327 #ifdef COB_32_BIT_LONG
7328 check_and_set_usage (CB_USAGE_SIGNED_INT);
7329 #else
7330 check_and_set_usage (CB_USAGE_SIGNED_LONG);
7331 #endif
7332 }
7333 | UNSIGNED_SHORT
7334 {
7335 check_and_set_usage (CB_USAGE_UNSIGNED_SHORT);
7336 }
7337 | UNSIGNED_INT
7338 {
7339 check_and_set_usage (CB_USAGE_UNSIGNED_INT);
7340 }
7341 | UNSIGNED_LONG
7342 {
7343 #ifdef COB_32_BIT_LONG
7344 check_and_set_usage (CB_USAGE_UNSIGNED_INT);
7345 #else
7346 check_and_set_usage (CB_USAGE_UNSIGNED_LONG);
7347 #endif
7348 }
7349 | BINARY_CHAR _signed
7350 {
7351 check_and_set_usage (CB_USAGE_SIGNED_CHAR);
7352 }
7353 | BINARY_CHAR UNSIGNED
7354 {
7355 check_and_set_usage (CB_USAGE_UNSIGNED_CHAR);
7356 }
7357 | BINARY_SHORT _signed
7358 {
7359 check_and_set_usage (CB_USAGE_SIGNED_SHORT);
7360 }
7361 | BINARY_SHORT UNSIGNED
7362 {
7363 check_and_set_usage (CB_USAGE_UNSIGNED_SHORT);
7364 }
7365 | BINARY_LONG _signed
7366 {
7367 check_and_set_usage (CB_USAGE_SIGNED_INT);
7368 }
7369 | BINARY_LONG UNSIGNED
7370 {
7371 check_and_set_usage (CB_USAGE_UNSIGNED_INT);
7372 }
7373 | BINARY_DOUBLE _signed
7374 {
7375 check_and_set_usage (CB_USAGE_SIGNED_LONG);
7376 }
7377 | BINARY_DOUBLE UNSIGNED
7378 {
7379 check_and_set_usage (CB_USAGE_UNSIGNED_LONG);
7380 }
7381 | BINARY_C_LONG _signed
7382 {
7383 #ifdef COB_32_BIT_LONG
7384 check_and_set_usage (CB_USAGE_SIGNED_INT);
7385 #else
7386 check_and_set_usage (CB_USAGE_SIGNED_LONG);
7387 #endif
7388 }
7389 | BINARY_C_LONG UNSIGNED
7390 {
7391 #ifdef COB_32_BIT_LONG
7392 check_and_set_usage (CB_USAGE_UNSIGNED_INT);
7393 #else
7394 check_and_set_usage (CB_USAGE_UNSIGNED_LONG);
7395 #endif
7396 }
7397 | FLOAT_BINARY_32
7398 {
7399 check_and_set_usage (CB_USAGE_FP_BIN32);
7400 }
7401 | FLOAT_BINARY_64
7402 {
7403 check_and_set_usage (CB_USAGE_FP_BIN64);
7404 }
7405 | FLOAT_BINARY_128
7406 {
7407 check_and_set_usage (CB_USAGE_FP_BIN128);
7408 }
7409 | FLOAT_DECIMAL_16
7410 {
7411 check_and_set_usage (CB_USAGE_FP_DEC64);
7412 }
7413 | FLOAT_DECIMAL_34
7414 {
7415 check_and_set_usage (CB_USAGE_FP_DEC128);
7416 }
7417 | NATIONAL
7418 {
7419 check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate);
7420 CB_UNFINISHED ("USAGE NATIONAL");
7421 }
7422 ;
7423
7424 double_usage:
7425 COMP_2
7426 | FLOAT_LONG /* alias from DOUBLE (ACU) in reserved.c */
7427 ;
7428
7429 _font_name:
7430 /* empty */
7431 | DEFAULT_FONT
7432 | FIXED_FONT
7433 | TRADITIONAL_FONT
7434 | SMALL_FONT
7435 | MEDIUM_FONT
7436 | LARGE_FONT
7437 ;
7438
7439 _layout_name:
7440 /* empty */
7441 | LM_RESIZE
7442 ;
7443
7444 /* SIGN clause */
7445
7446 sign_clause:
7447 _sign_is LEADING flag_separate
7448 {
7449 check_repeated ("SIGN", SYN_CLAUSE_6, &check_pic_duplicate);
7450 current_field->flag_sign_clause = 1;
7451 current_field->flag_sign_separate = ($3 ? 1 : 0);
7452 current_field->flag_sign_leading = 1;
7453 }
7454 | _sign_is TRAILING flag_separate
7455 {
7456 check_repeated ("SIGN", SYN_CLAUSE_6, &check_pic_duplicate);
7457 current_field->flag_sign_clause = 1;
7458 current_field->flag_sign_separate = ($3 ? 1 : 0);
7459 current_field->flag_sign_leading = 0;
7460 }
7461 ;
7462
7463
7464 /* REPORT (RD) OCCURS clause */
7465
7466 report_occurs_clause:
7467 OCCURS integer _occurs_to_integer _times
7468 _occurs_depending _occurs_step
7469 {
7470 /* most of the field attributes are set when parsing the phrases */;
7471 setup_occurs ();
7472 setup_occurs_min_max ($2, $3);
7473 }
7474 ;
7475
7476 _occurs_step:
7477 | STEP integer
7478 {
7479 current_field->step_count = cb_get_int ($2);
7480 }
7481 ;
7482
7483 /* OCCURS clause */
7484
7485 occurs_clause:
7486 OCCURS integer _occurs_to_integer _times
7487 _occurs_depending _occurs_keys_and_indexed
7488 {
7489 /* most of the field attributes are set when parsing the phrases */;
7490 setup_occurs ();
7491 setup_occurs_min_max ($2, $3);
7492 }
7493 | OCCURS _occurs_integer_to UNBOUNDED _times
7494 DEPENDING _on reference _occurs_keys_and_indexed
7495 {
7496 current_field->flag_unbounded = 1;
7497 if (current_field->parent) {
7498 current_field->parent->flag_unbounded = 1;
7499 }
7500 current_field->depending = $7;
7501 /* most of the field attributes are set when parsing the phrases */;
7502 setup_occurs ();
7503 setup_occurs_min_max ($2, cb_int0);
7504 }
7505 | OCCURS DYNAMIC _capacity_in _occurs_from_integer
7506 _occurs_to_integer _occurs_initialized _occurs_keys_and_indexed
7507 {
7508 setup_occurs ();
7509 current_field->occurs_min = $4 ? cb_get_int ($4) : 0;
7510 if ($5) {
7511 current_field->occurs_max = cb_get_int ($5);
7512 if (current_field->occurs_max <= current_field->occurs_min) {
7513 cb_error (_("OCCURS TO must be greater than OCCURS FROM"));
7514 }
7515 } else {
7516 current_field->occurs_max = 0;
7517 }
7518 CB_PENDING ("OCCURS DYNAMIC");
7519 }
7520 ;
7521
7522 _occurs_to_integer:
7523 /* empty */ { $$ = NULL; }
7524 | TO integer { $$ = $2; }
7525 ;
7526
7527 _occurs_from_integer:
7528 /* empty */ { $$ = NULL; }
7529 | FROM integer { $$ = $2; }
7530 ;
7531
7532 _occurs_integer_to:
7533 /* empty */ { $$ = NULL; }
7534 | integer TO { $$ = $1; }
7535 ;
7536
7537 _occurs_depending:
7538 | DEPENDING _on reference
7539 {
7540 current_field->depending = $3;
7541 }
7542 ;
7543 _capacity_in:
7544 | CAPACITY _in WORD
7545 {
7546 $$ = cb_build_index ($3, cb_zero, 0, current_field);
7547 CB_FIELD_PTR ($$)->index_type = CB_STATIC_INT_INDEX;
7548 }
7549 ;
7550
7551 _occurs_initialized:
7552 | INITIALIZED
7553 {
7554 /* current_field->initialized = 1; */
7555 }
7556 ;
7557
7558 _occurs_keys_and_indexed:
7559 /* empty */
7560 | occurs_keys occurs_indexed
7561 | occurs_indexed
7562 {
7563 if (!cb_relaxed_syntax_checks) {
7564 cb_error (_("INDEXED should follow ASCENDING/DESCENDING"));
7565 } else {
7566 cb_warning (cb_warn_additional, _("INDEXED should follow ASCENDING/DESCENDING"));
7567 }
7568 }
7569 occurs_keys
7570 | occurs_indexed
7571 | occurs_keys
7572 ;
7573
7574 occurs_keys:
7575 occurs_key_list
7576 {
7577 cb_tree l;
7578 struct cb_key *keys;
7579 int i;
7580 int nkeys;
7581
7582 l = $1;
7583 nkeys = cb_list_length ($1);
7584 keys = cobc_parse_malloc (sizeof (struct cb_key) * nkeys);
7585
7586 for (i = 0; i < nkeys; i++) {
7587 keys[i].dir = CB_PURPOSE_INT (l);
7588 keys[i].key = CB_VALUE (l);
7589 l = CB_CHAIN (l);
7590 }
7591 current_field->keys = keys;
7592 current_field->nkeys = nkeys;
7593 }
7594 ;
7595
7596 occurs_key_list:
7597 occurs_key_field
7598 | occurs_key_field occurs_key_list
7599 ;
7600
7601 occurs_key_field:
7602 ascending_or_descending _key _is single_reference_list
7603 {
7604 cb_tree ref = NULL;
7605 cb_tree rchain = NULL;
7606 cb_tree l;
7607
7608 /* create reference chaing all the way up
7609 as later fields may have same name */
7610 if (!within_typedef_definition) {
7611 rchain = cb_build_full_field_reference (current_field->parent);
7612 }
7613
7614 for (l = $4; l; l = CB_CHAIN (l)) {
7615 CB_PURPOSE (l) = $1;
7616 ref = CB_VALUE (l);
7617 if (CB_VALID_TREE(ref)) {
7618 CB_REFERENCE (ref)->chain = rchain;
7619 }
7620 }
7621 keys_list = cb_list_append (keys_list, $4);
7622 $$ = keys_list;
7623 }
7624 ;
7625
7626 ascending_or_descending:
7627 ASCENDING { $$ = cb_int (COB_ASCENDING); }
7628 | DESCENDING { $$ = cb_int (COB_DESCENDING); }
7629 ;
7630
7631 _occurs_indexed:
7632 /* empty */
7633 | occurs_indexed
7634 ;
7635 occurs_indexed:
7636 INDEXED _by occurs_index_list
7637 {
7638 current_field->index_list = $3;
7639 }
7640 ;
7641
7642 occurs_index_list:
7643 occurs_index { $$ = CB_LIST_INIT ($1); }
7644 | occurs_index_list
7645 occurs_index { $$ = cb_list_add ($1, $2); }
7646 ;
7647
7648 occurs_index:
7649 unqualified_word
7650 {
7651 $$ = cb_build_index ($1, cb_int1, 1U, current_field);
7652 CB_FIELD_PTR ($$)->index_type = CB_STATIC_INT_INDEX;
7653 }
7654 ;
7655
7656
7657 /* JUSTIFIED clause */
7658
7659 justified_clause:
7660 JUSTIFIED _right
7661 {
7662 check_repeated ("JUSTIFIED", SYN_CLAUSE_8, &check_pic_duplicate);
7663 current_field->flag_justified = 1;
7664 }
7665 ;
7666
7667
7668 /* SYNCHRONIZED clause */
7669
7670 synchronized_clause:
7671 SYNCHRONIZED _left_or_right
7672 {
7673 check_repeated ("SYNCHRONIZED", SYN_CLAUSE_9, &check_pic_duplicate);
7674 if (cb_verify (cb_synchronized_clause, _("SYNCHRONIZED clause"))) {
7675 current_field->flag_synchronized = 1;
7676 }
7677 }
7678 ;
7679
7680 _left_or_right:
7681 /* empty -> implemented as LEFT */
7682 | LEFT
7683 | RIGHT
7684 {
7685 CB_PENDING ("SYNCHRONIZED RIGHT");
7686 }
7687 ;
7688
7689
7690 /* BLANK clause */
7691
7692 blank_clause:
7693 BLANK _when ZERO
7694 {
7695 check_repeated ("BLANK", SYN_CLAUSE_10, &check_pic_duplicate);
7696 current_field->flag_blank_zero = 1;
7697 }
7698 ;
7699
7700
7701 /* BASED clause */
7702
7703 based_clause:
7704 BASED
7705 {
7706 check_repeated ("BASED", SYN_CLAUSE_11, &check_pic_duplicate);
7707 if (current_storage == CB_STORAGE_FILE) {
7708 cb_error (_("%s not allowed here"), "BASED");
7709 } else if (current_field->level != 1 && current_field->level != 77) {
7710 cb_error (_("%s only allowed at 01/77 level"), "BASED");
7711 } else if (!qualifier) {
7712 cb_error (_("%s requires a data name"), "BASED");
7713 } else if (current_field->flag_external) {
7714 cb_error (_("%s and %s are mutually exclusive"), "BASED", "EXTERNAL");
7715 } else if (current_field->redefines) {
7716 cb_error (_("%s and %s are mutually exclusive"), "BASED", "REDEFINES");
7717 } else if (current_field->flag_any_length) {
7718 cb_error (_("%s and %s are mutually exclusive"), "BASED", "ANY LENGTH");
7719 } else if (current_field->flag_occurs) {
7720 cb_error (_("%s and %s are mutually exclusive"), "BASED", "OCCURS");
7721 } else {
7722 current_field->flag_item_based = 1;
7723 }
7724 }
7725 ;
7726
7727 /* VALUE clause */
7728
7729 value_clause:
7730 VALUE _is_are value_item_list
7731 {
7732 check_repeated ("VALUE", SYN_CLAUSE_12, &check_pic_duplicate);
7733 current_field->values = $3;
7734 }
7735 _false_is
7736 ;
7737
7738 value_item_list:
7739 value_item { $$ = CB_LIST_INIT ($1); }
7740 | value_item_list value_item { $$ = cb_list_add ($1, $2); }
7741 ;
7742
7743 value_item:
7744 lit_or_length THRU lit_or_length { $$ = CB_BUILD_PAIR ($1, $3); }
7745 | constant_expression
7746 ;
7747
7748 _false_is:
7749 /* empty */
7750 | _when_set_to TOK_FALSE _is lit_or_length
7751 {
7752 if (current_field->level != 88) {
7753 cb_error (_("FALSE clause only allowed for 88 level"));
7754 }
7755 current_field->false_88 = CB_LIST_INIT ($4);
7756 }
7757 ;
7758
7759 /* ANY LENGTH clause */
7760
7761 any_length_clause:
7762 ANY LENGTH
7763 {
7764 check_repeated ("ANY", SYN_CLAUSE_14, &check_pic_duplicate);
7765 if (current_field->flag_item_based) {
7766 cb_error (_("%s and %s are mutually exclusive"), "BASED", "ANY LENGTH");
7767 } else {
7768 current_field->flag_any_length = 1;
7769 }
7770 }
7771 | ANY NUMERIC
7772 {
7773 check_repeated ("ANY", SYN_CLAUSE_14, &check_pic_duplicate);
7774 if (current_field->flag_item_based) {
7775 cb_error (_("%s and %s are mutually exclusive"), "BASED", "ANY NUMERIC");
7776 } else {
7777 current_field->flag_any_length = 1;
7778 current_field->flag_any_numeric = 1;
7779 }
7780 }
7781 ;
7782
7783 /* EXTERNAL-FORM clause */
7784
7785 external_form_clause:
7786 _is EXTERNAL_FORM
7787 {
7788 check_repeated ("EXTERNAL-FORM", SYN_CLAUSE_2, &check_pic_duplicate);
7789 CB_PENDING ("EXTERNAL-FORM");
7790 if (current_storage != CB_STORAGE_WORKING) {
7791 cb_error (_("%s not allowed here"), "EXTERNAL-FORM");
7792 } else if (current_field->level != 1) { /* docs say: at group level */
7793 cb_error (_("%s only allowed at 01 level"), "EXTERNAL-FORM");
7794 } else if (!qualifier) {
7795 cb_error (_("%s requires a data name"), "EXTERNAL-FORM");
7796 } else if (current_field->redefines) {
7797 cb_error (_("%s and %s combination not allowed"), "EXTERNAL-FORM", "REDEFINES");
7798 } else {
7799 current_field->flag_is_external_form = 1;
7800 }
7801 }
7802 ;
7803
7804 /* IDENTIFIED BY clause */
7805
7806 identified_by_clause:
7807 /* minimal glitch: IS should only be usable if EXTERNAL-FORM comes directly before */
7808 /* glitch: EXTERNAL-FORM clause can come after IDENTIFIED BY clause */
7809 _is IDENTIFIED _by id_or_lit
7810 {
7811 check_repeated ("IDENTIFIED BY", SYN_CLAUSE_3, &check_pic_duplicate);
7812 if (!current_field->flag_is_external_form) {
7813 CB_PENDING ("EXTERNAL-FORM (IDENTIFIED BY)");
7814 if (current_storage != CB_STORAGE_WORKING) {
7815 cb_error (_("%s not allowed here"), "IDENTIFIED BY");
7816 } else if (!qualifier) {
7817 cb_error (_("%s requires a data name"), "IDENTIFIED BY");
7818 } else if (current_field->redefines) {
7819 cb_error (_("%s and %s combination not allowed"), "IDENTIFIED BY", "REDEFINES");
7820 }
7821 }
7822 current_field->external_form_identifier = $4;
7823 }
7824 ;
7825
7826 /* LOCAL-STORAGE SECTION */
7827
7828 _local_storage_section:
7829 | LOCAL_STORAGE SECTION TOK_DOT
7830 {
7831 check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
7832 header_check |= COBC_HD_LOCAL_STORAGE_SECTION;
7833 current_storage = CB_STORAGE_LOCAL;
7834 if (current_program->nested_level) {
7835 cb_error (_("%s not allowed in nested programs"), "LOCAL-STORAGE");
7836 } else if (cb_local_implies_recursive) {
7837 current_program->flag_recursive = 1;
7838 }
7839 }
7840 _record_description_list
7841 {
7842 if ($5) {
7843 current_program->local_storage = CB_FIELD ($5);
7844 }
7845 }
7846 ;
7847
7848
7849 /* LINKAGE SECTION */
7850
7851 _linkage_section:
7852 | LINKAGE SECTION TOK_DOT
7853 {
7854 check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
7855 header_check |= COBC_HD_LINKAGE_SECTION;
7856 current_storage = CB_STORAGE_LINKAGE;
7857 }
7858 _record_description_list
7859 {
7860 if ($5) {
7861 current_program->linkage_storage = CB_FIELD ($5);
7862 }
7863 }
7864 ;
7865
7866 /* REPORT SECTION */
7867
7868 _report_section:
7869 | REPORT SECTION TOK_DOT
7870 {
7871 header_check |= COBC_HD_REPORT_SECTION;
7872 current_storage = CB_STORAGE_REPORT;
7873 description_field = NULL;
7874 current_program->flag_report = 1;
7875 cb_clear_real_field ();
7876 }
7877 _report_description_sequence
7878 ;
7879
7880 _report_description_sequence:
7881 | _report_description_sequence report_description
7882 ;
7883
7884 /* RD report description */
7885
7886 report_description:
7887 RD report_name
7888 {
7889 if (CB_INVALID_TREE ($2)) {
7890 YYERROR;
7891 } else {
7892 current_field = NULL;
7893 control_field = NULL;
7894 description_field = NULL;
7895 current_report = CB_REPORT_PTR ($2);
7896 }
7897 check_duplicate = 0;
7898 }
7899 _report_description_options TOK_DOT
7900 _report_group_description_list
7901 {
7902 $$ = get_finalized_description_tree ();
7903
7904 current_program->report_storage = description_field;
7905 current_program->flag_report = 1;
7906 if (current_report->records == NULL) {
7907 current_report->records = description_field;
7908 }
7909 finalize_report (current_report, description_field);
7910 }
7911 ;
7912
7913 _report_description_options:
7914 | _report_description_options report_description_option
7915 | error TOK_DOT
7916 {
7917 yyerrok;
7918 }
7919 ;
7920
7921 report_description_option:
7922 _is GLOBAL
7923 {
7924 check_repeated ("GLOBAL", SYN_CLAUSE_1, &check_duplicate);
7925 current_report->global = 1;
7926 cb_error (_("GLOBAL is not allowed with RD"));
7927 }
7928 | _with CODE _is id_or_lit
7929 {
7930 check_repeated ("CODE", SYN_CLAUSE_2, &check_duplicate);
7931 current_report->code_clause = $4;
7932 }
7933 | control_clause
7934 | page_limit_clause
7935 ;
7936
7937 /* REPORT control breaks */
7938
7939 control_clause:
7940 control_keyword control_field_list
7941 {
7942 check_repeated ("CONTROL", SYN_CLAUSE_3, &check_duplicate);
7943 }
7944 ;
7945
7946 control_field_list:
7947 control_final_tag control_identifier_list
7948 | control_final_tag
7949 | control_identifier_list
7950 ;
7951
7952 control_final_tag:
7953 FINAL
7954 {
7955 current_report->control_final = 1;
7956 }
7957 ;
7958
7959 control_identifier_list:
7960 control_identifier
7961 | control_identifier_list control_identifier
7962 ;
7963
7964 control_identifier:
7965 identifier
7966 {
7967 /* Add field to current control list */
7968 CB_ADD_TO_CHAIN ($1, current_report->controls);
7969 }
7970 ;
7971
7972 /* PAGE LIMIT clause */
7973
7974 page_limit_clause:
7975 PAGE _limits page_line_column
7976 _page_heading_list
7977 {
7978 check_repeated ("PAGE", SYN_CLAUSE_4, &check_duplicate);
7979 if (!current_report->heading) {
7980 current_report->heading = 1;
7981 }
7982 if (!current_report->first_detail) {
7983 current_report->first_detail = current_report->heading;
7984 }
7985 if (!current_report->last_control) {
7986 if (current_report->last_detail) {
7987 current_report->last_control = current_report->last_detail;
7988 } else if (current_report->footing) {
7989 current_report->last_control = current_report->footing;
7990 } else {
7991 current_report->last_control = current_report->lines;
7992 }
7993 if (current_report->t_last_detail) {
7994 current_report->t_last_control = current_report->t_last_detail;
7995 } else if (current_report->t_footing) {
7996 current_report->t_last_control = current_report->t_footing;
7997 } else if(current_report->t_lines) {
7998 current_report->t_last_control = current_report->t_lines;
7999 }
8000 }
8001 if (!current_report->last_detail && !current_report->footing) {
8002 current_report->last_detail = current_report->lines;
8003 current_report->footing = current_report->lines;
8004 } else if (!current_report->last_detail) {
8005 current_report->last_detail = current_report->footing;
8006 } else if (!current_report->footing) {
8007 current_report->footing = current_report->last_detail;
8008 }
8009 /* PAGE LIMIT values checked in finalize_report in typeck.c */
8010 }
8011 ;
8012
8013 page_line_column:
8014 integer_or_zero_or_ident _line_or_lines
8015 {
8016 if (CB_LITERAL_P ($1)) {
8017 current_report->lines = cb_get_int ($1);
8018 if (current_report->lines > 999) {
8019 cb_error ("PAGE LIMIT lines > 999");
8020 }
8021 } else {
8022 current_report->t_lines = $1;
8023 }
8024 }
8025 | page_limit_cols
8026 | integer_or_zero_or_ident line_or_lines page_limit_cols
8027 {
8028 if (CB_LITERAL_P ($1)) {
8029 current_report->lines = cb_get_int ($1);
8030 if (current_report->lines > 999) {
8031 cb_error ("PAGE LIMIT lines > 999");
8032 }
8033 } else {
8034 current_report->t_lines = $1;
8035 }
8036 }
8037 ;
8038
8039 page_limit_cols:
8040 integer_or_zero_or_ident columns_or_cols
8041 {
8042 /* may be repeated later by page detail */
8043 check_repeated ("LINE LIMIT", SYN_CLAUSE_5, &check_duplicate);
8044 if (CB_LITERAL_P ($1)) {
8045 current_report->columns = cb_get_int ($1);
8046 } else {
8047 current_report->t_columns = $1;
8048 }
8049 }
8050 ;
8051
8052 integer_or_zero_or_ident:
8053 integer_or_zero
8054 | identifier
8055 ;
8056
8057 _page_heading_list:
8058 | _page_heading_list page_detail
8059 ;
8060
8061
8062 page_detail:
8063 heading_clause
8064 | first_detail
8065 | last_heading
8066 | last_detail
8067 | footing_clause
8068 | LINE_LIMIT _is integer_or_zero_or_ident
8069 {
8070 check_repeated ("LINE LIMIT", SYN_CLAUSE_5, &check_duplicate);
8071 if (CB_LITERAL_P ($3)) {
8072 current_report->columns = cb_get_int ($3);
8073 } else {
8074 current_report->t_columns = $3;
8075 }
8076 }
8077 ;
8078
8079 heading_clause:
8080 HEADING _is integer_or_zero_or_ident
8081 {
8082 check_repeated ("HEADING", SYN_CLAUSE_6, &check_duplicate);
8083 error_if_no_page_lines_limit ("HEADING");
8084
8085 if (CB_LITERAL_P ($3)) {
8086 current_report->heading = cb_get_int ($3);
8087 } else {
8088 current_report->t_heading = $3;
8089 }
8090 }
8091 ;
8092
8093 first_detail:
8094 FIRST detail_keyword _is integer_or_zero_or_ident
8095 {
8096 check_repeated ("FIRST DETAIL", SYN_CLAUSE_7, &check_duplicate);
8097 error_if_no_page_lines_limit ("FIRST DETAIL");
8098
8099 if (CB_LITERAL_P ($4)) {
8100 current_report->first_detail = cb_get_int ($4);
8101 } else {
8102 current_report->t_first_detail = $4;
8103 }
8104 }
8105 ;
8106
8107 last_heading:
8108 LAST ch_keyword _is integer_or_zero_or_ident
8109 {
8110 check_repeated ("LAST CONTROL HEADING", SYN_CLAUSE_8, &check_duplicate);
8111 error_if_no_page_lines_limit ("LAST CONTROL HEADING");
8112
8113 if (CB_LITERAL_P ($4)) {
8114 current_report->last_control = cb_get_int ($4);
8115 } else {
8116 current_report->t_last_control = $4;
8117 }
8118 }
8119 ;
8120
8121 last_detail:
8122 LAST detail_keyword _is integer_or_zero_or_ident
8123 {
8124 check_repeated ("LAST DETAIL", SYN_CLAUSE_9, &check_duplicate);
8125 error_if_no_page_lines_limit ("LAST DETAIL");
8126
8127 if (CB_LITERAL_P ($4)) {
8128 current_report->last_detail = cb_get_int ($4);
8129 } else {
8130 current_report->t_last_detail = $4;
8131 }
8132 }
8133 ;
8134
8135 footing_clause:
8136 FOOTING _is integer_or_zero_or_ident
8137 {
8138 check_repeated ("FOOTING", SYN_CLAUSE_10, &check_duplicate);
8139 error_if_no_page_lines_limit ("FOOTING");
8140
8141 if (CB_LITERAL_P ($3)) {
8142 current_report->footing = cb_get_int ($3);
8143 } else {
8144 current_report->t_footing = $3;
8145 }
8146 }
8147 ;
8148
8149 _report_group_description_list:
8150 | _report_group_description_list report_group_description_entry
8151 ;
8152
8153 report_group_description_entry:
8154 level_number _entry_name
8155 {
8156 if (set_current_field($1, $2)) {
8157 YYERROR;
8158 }
8159 if (!description_field) {
8160 description_field = current_field;
8161 }
8162 }
8163 _report_group_options TOK_DOT
8164 | level_number error TOK_DOT
8165 {
8166 /* Free tree associated with level number */
8167 cobc_parse_free ($1);
8168 cb_unput_dot ();
8169 yyerrok;
8170 check_pic_duplicate = 0;
8171 check_duplicate = 0;
8172 current_field = cb_get_real_field ();
8173 }
8174 ;
8175
8176 _report_group_options:
8177 | _report_group_options report_group_option
8178 ;
8179
8180 report_group_option:
8181 type_is_clause
8182 | next_group_clause
8183 | line_clause
8184 | picture_clause
8185 | usage_clause
8186 | type_to_clause
8187 | sign_clause
8188 | justified_clause
8189 | column_clause
8190 | blank_clause
8191 | source_clause
8192 | sum_clause_list
8193 | value_clause
8194 | present_when_condition
8195 | group_indicate_clause
8196 | report_occurs_clause
8197 | report_varying_clause
8198 ;
8199
8200 type_is_clause:
8201 TYPE _is type_option
8202 {
8203 check_repeated ("TYPE IS", SYN_CLAUSE_16, &check_pic_duplicate);
8204 }
8205 ;
8206
8207 type_option:
8208 rh_keyword
8209 {
8210 current_field->report_flag |= COB_REPORT_HEADING;
8211 }
8212 | ph_keyword
8213 {
8214 current_field->report_flag |= COB_REPORT_PAGE_HEADING;
8215 }
8216 | ch_keyword _on_for _control_heading_final
8217 | cf_keyword _on_for _control_footing_final
8218 | detail_keyword
8219 {
8220 if (current_report != NULL) {
8221 current_report->has_detail = 1;
8222 }
8223 current_field->report_flag |= COB_REPORT_DETAIL;
8224 }
8225 | pf_keyword
8226 {
8227 current_field->report_flag |= COB_REPORT_PAGE_FOOTING;
8228 }
8229 | rf_keyword
8230 {
8231 current_field->report_flag |= COB_REPORT_FOOTING;
8232 }
8233 ;
8234
8235 _control_heading_final:
8236 /* empty */
8237 {
8238 current_field->report_flag |= COB_REPORT_CONTROL_HEADING;
8239 }
8240 | identifier _or_page
8241 {
8242 current_field->report_flag |= COB_REPORT_CONTROL_HEADING;
8243 current_field->report_control = $1;
8244 if ($2) {
8245 current_field->report_flag |= COB_REPORT_PAGE;
8246 }
8247 }
8248 | FINAL _or_page
8249 {
8250 current_field->report_flag |= COB_REPORT_CONTROL_HEADING_FINAL;
8251 }
8252 ;
8253
8254 /* TODO: check where this should be allowed
8255 and what results are expected */
8256
8257 _or_page:
8258 /* empty */ {$$ = NULL;}
8259 | OR PAGE {$$ = cb_int0;}
8260 ;
8261
8262 _control_footing_final:
8263 /* empty */
8264 {
8265 current_field->report_flag |= COB_REPORT_CONTROL_FOOTING;
8266 }
8267 | identifier _or_page
8268 {
8269 current_field->report_flag |= COB_REPORT_CONTROL_FOOTING;
8270 current_field->report_control = $1;
8271 }
8272 | FINAL _or_page
8273 {
8274 current_field->report_flag |= COB_REPORT_CONTROL_FOOTING_FINAL;
8275 }
8276 | ALL
8277 {
8278 current_field->report_flag |= COB_REPORT_CONTROL_FOOTING;
8279 current_field->report_flag |= COB_REPORT_ALL;
8280 }
8281 ;
8282
8283 next_group_clause:
8284 NEXT_GROUP _is next_group_plus
8285 {
8286 check_repeated ("NEXT GROUP", SYN_CLAUSE_17, &check_pic_duplicate);
8287 }
8288 ;
8289
8290 next_group_plus:
8291 integer
8292 {
8293 if (CB_LITERAL_P($1) && CB_LITERAL ($1)->sign > 0) {
8294 current_field->report_flag |= COB_REPORT_NEXT_GROUP_PLUS;
8295 } else {
8296 current_field->report_flag |= COB_REPORT_NEXT_GROUP_LINE;
8297 }
8298 current_field->next_group_line = cb_get_int ($1);
8299 }
8300 | plus integer
8301 {
8302 current_field->report_flag |= COB_REPORT_NEXT_GROUP_PLUS;
8303 current_field->next_group_line = cb_get_int($2);
8304 }
8305 | next_page
8306 {
8307 current_field->report_flag |= COB_REPORT_NEXT_GROUP_PAGE;
8308 }
8309 ;
8310
8311 next_page:
8312 NEXT_PAGE
8313 | PAGE
8314 | NEXT
8315 ;
8316
8317 sum_clause_list:
8318 SUM _of report_x_list _reset_clause
8319 {
8320 check_repeated ("SUM", SYN_CLAUSE_19, &check_pic_duplicate);
8321 current_field->report_sum_list = $3;
8322 build_sum_counter (current_report, current_field);
8323 }
8324 ;
8325
8326 _reset_clause:
8327 | RESET _on data_or_final
8328 | UPON identifier
8329 {
8330 current_field->report_sum_upon = $2;
8331 }
8332 ;
8333
8334 data_or_final:
8335 identifier
8336 {
8337 current_field->report_reset = $1;
8338 }
8339 | FINAL
8340 {
8341 current_field->report_flag |= COB_REPORT_RESET_FINAL;
8342 }
8343 ;
8344
8345 present_when_condition:
8346 present_absent WHEN condition
8347 {
8348 check_repeated ("PRESENT", SYN_CLAUSE_20, &check_pic_duplicate);
8349 current_field->report_when = $3;
8350 }
8351 | present_absent AFTER _new _page_or_id
8352 {
8353 check_repeated ("PRESENT", SYN_CLAUSE_20, &check_pic_duplicate);
8354 current_field->report_flag |= COB_REPORT_PRESENT;
8355 current_field->report_flag &= ~COB_REPORT_BEFORE;
8356 }
8357 | present_absent JUSTIFIED AFTER _new PAGE
8358 {
8359 check_repeated ("PRESENT", SYN_CLAUSE_20, &check_pic_duplicate);
8360 current_field->report_flag |= COB_REPORT_PRESENT;
8361 current_field->report_flag &= ~COB_REPORT_BEFORE;
8362 current_field->report_flag |= COB_REPORT_PAGE;
8363 }
8364 | present_absent BEFORE _new _page_or_id
8365 {
8366 check_repeated ("PRESENT", SYN_CLAUSE_20, &check_pic_duplicate);
8367 current_field->report_flag |= COB_REPORT_PRESENT;
8368 current_field->report_flag |= COB_REPORT_BEFORE;
8369 }
8370 | present_absent JUSTIFIED BEFORE _new PAGE
8371 {
8372 check_repeated ("PRESENT", SYN_CLAUSE_20, &check_pic_duplicate);
8373 current_field->report_flag |= COB_REPORT_PRESENT;
8374 current_field->report_flag |= COB_REPORT_BEFORE;
8375 current_field->report_flag |= COB_REPORT_PAGE;
8376 }
8377 ;
8378
8379 present_absent:
8380 PRESENT
8381 {
8382 current_field->report_flag |= COB_REPORT_PRESENT;
8383 }
8384 | ABSENT
8385 {
8386 current_field->report_flag |= COB_REPORT_PRESENT;
8387 current_field->report_flag |= COB_REPORT_NEGATE;
8388 }
8389 ;
8390
8391 _page_or_id:
8392 /* empty */
8393 | page_or_ids _page_or_id
8394 ;
8395
8396 page_or_ids:
8397 PAGE
8398 {
8399 current_field->report_flag |= COB_REPORT_PAGE;
8400 }
8401 | identifier
8402 {
8403 current_field->report_control = $1;
8404 }
8405 | OR
8406 ;
8407
8408 report_varying_clause:
8409 VARYING identifier FROM arith_x BY arith_x
8410 {
8411 CB_PENDING ("RW VARYING clause");
8412 }
8413 ;
8414
8415 line_clause:
8416 line_keyword_clause _line_clause_options
8417 {
8418 check_repeated ("LINE", SYN_CLAUSE_21, &check_pic_duplicate);
8419 current_field->report_flag |= COB_REPORT_LINE;
8420 }
8421 ;
8422
8423 line_keyword_clause:
8424 LINE _number_or_numbers _is_are
8425 | LINES _are
8426 ;
8427
8428 _line_clause_options:
8429 /* empty */
8430 | line_clause_option _line_clause_options
8431 ;
8432
8433 line_clause_option:
8434 NEXT_PAGE /* token contains optional ON */
8435 {
8436 current_field->report_flag |= COB_REPORT_LINE_NEXT_PAGE;
8437 }
8438 | _plus integer_or_zero
8439 {
8440 current_field->report_line = cb_get_int ($2);
8441 if ($1) {
8442 current_field->report_flag |= COB_REPORT_LINE_PLUS;
8443 if (current_field->report_line == 0) {
8444 CB_PENDING ("LINE PLUS 0");
8445 }
8446 }
8447 }
8448 ;
8449
8450
8451 column_clause:
8452 col_keyword_clause col_or_plus
8453 {
8454 check_repeated ("COLUMN", SYN_CLAUSE_18, &check_pic_duplicate);
8455 if ((current_field->report_flag & (COB_REPORT_COLUMN_LEFT|COB_REPORT_COLUMN_RIGHT|COB_REPORT_COLUMN_CENTER))
8456 && (current_field->report_flag & COB_REPORT_COLUMN_PLUS)) {
8457 if (cb_relaxed_syntax_checks) {
8458 cb_warning (COBC_WARN_FILLER, _("PLUS is not recommended with LEFT, RIGHT or CENTER"));
8459 } else {
8460 cb_error (_("PLUS is not allowed with LEFT, RIGHT or CENTER"));
8461 }
8462 }
8463 }
8464 ;
8465
8466 col_keyword_clause:
8467 column_or_cols _number_or_numbers _orientation _is_are
8468 ;
8469
8470 _orientation:
8471 /* empty */
8472 | _left_right_center
8473 ;
8474
8475 _left_right_center:
8476 LEFT
8477 {
8478 current_field->report_flag |= COB_REPORT_COLUMN_LEFT;
8479 }
8480 | RIGHT
8481 {
8482 current_field->report_flag |= COB_REPORT_COLUMN_RIGHT;
8483 }
8484 | CENTER
8485 {
8486 current_field->report_flag |= COB_REPORT_COLUMN_CENTER;
8487 }
8488 ;
8489
8490 col_or_plus:
8491 plus integer_or_zero
8492 {
8493 int colnum = cb_get_int ($2);
8494 if (colnum != 0) {
8495 if (current_field->parent
8496 && current_field->parent->children == current_field) {
8497 cb_warning (COBC_WARN_FILLER, _("PLUS is ignored on first field of line"));
8498 if (current_field->step_count == 0) {
8499 current_field->step_count = colnum;
8500 }
8501 } else {
8502 current_field->report_flag |= COB_REPORT_COLUMN_PLUS;
8503 }
8504 } else {
8505 colnum = 0;
8506 }
8507 if (current_field->report_column == 0) {
8508 current_field->report_column = colnum;
8509 }
8510 current_field->report_num_col++;
8511 }
8512 | column_integer_list
8513 ;
8514
8515 column_integer_list:
8516 column_integer
8517 | column_integer column_integer_list
8518 ;
8519
8520 column_integer:
8521 integer
8522 {
8523 int colnum;
8524 colnum = cb_get_int ($1);
8525 if (colnum < 0) {
8526 /* already handled by integer check */
8527 } else if (colnum == 0) {
8528 cb_error (_("invalid COLUMN integer; must be > 0"));
8529 } else if (colnum <= current_field->report_column) {
8530 cb_warning (COBC_WARN_FILLER, _("COLUMN numbers should increase"));
8531 }
8532 current_field->report_column_list =
8533 cb_list_append (current_field->report_column_list, CB_LIST_INIT ($1));
8534 if (current_field->report_column == 0) {
8535 current_field->report_column = colnum;
8536 }
8537 current_field->report_num_col++;
8538 }
8539 ;
8540
8541 source_clause:
8542 SOURCE _is arith_x flag_rounded
8543 {
8544 check_repeated ("SOURCE", SYN_CLAUSE_22, &check_pic_duplicate);
8545 current_field->report_source = $3;
8546 }
8547 ;
8548
8549 group_indicate_clause:
8550 GROUP _indicate
8551 {
8552 check_repeated ("GROUP", SYN_CLAUSE_23, &check_pic_duplicate);
8553 current_field->report_flag |= COB_REPORT_GROUP_INDICATE;
8554 }
8555 ;
8556
8557 /* SCREEN SECTION */
8558
8559 _screen_section:
8560 | SCREEN SECTION TOK_DOT
8561 {
8562 cobc_cs_check = CB_CS_SCREEN;
8563 current_storage = CB_STORAGE_SCREEN;
8564 current_field = NULL;
8565 description_field = NULL;
8566 cb_clear_real_field ();
8567 }
8568 _screen_description_list
8569 {
8570 if (description_field) {
8571 get_finalized_description_tree ();
8572 current_program->screen_storage = description_field;
8573 current_program->flag_screen = 1;
8574 }
8575 cobc_cs_check = 0;
8576 }
8577 ;
8578
8579 _screen_description_list:
8580 | screen_description_list
8581 ;
8582
8583 screen_description_list:
8584 screen_description TOK_DOT
8585 | screen_description_list screen_description TOK_DOT
8586 ;
8587
8588 screen_description:
8589 constant_entry
8590 /* normal screen definition */
8591 | level_number _entry_name
8592 {
8593 if (set_current_field ($1, $2)) {
8594 YYERROR;
8595 }
8596 if (current_field->parent) {
8597 current_field->screen_foreg = current_field->parent->screen_foreg;
8598 current_field->screen_backg = current_field->parent->screen_backg;
8599 current_field->screen_prompt = current_field->parent->screen_prompt;
8600 }
8601 }
8602 _screen_options
8603 {
8604 cob_flags_t flags;
8605
8606 if (current_field->parent) {
8607 flags = current_field->parent->screen_flag;
8608 flags &= ~COB_SCREEN_BLANK_LINE;
8609 flags &= ~COB_SCREEN_BLANK_SCREEN;
8610 flags &= ~COB_SCREEN_ERASE_EOL;
8611 flags &= ~COB_SCREEN_ERASE_EOS;
8612 flags &= ~COB_SCREEN_LINE_PLUS;
8613 flags &= ~COB_SCREEN_LINE_MINUS;
8614 flags &= ~COB_SCREEN_COLUMN_PLUS;
8615 flags &= ~COB_SCREEN_COLUMN_MINUS;
8616
8617 flags = zero_conflicting_flags (current_field->screen_flag,
8618 flags);
8619
8620 current_field->screen_flag |= flags;
8621 }
8622
8623 if (current_field->screen_flag & COB_SCREEN_INITIAL) {
8624 if (!(current_field->screen_flag & COB_SCREEN_INPUT)) {
8625 cb_error (_("INITIAL specified on non-input field"));
8626 }
8627 }
8628 if (!qualifier) {
8629 current_field->flag_filler = 1;
8630 }
8631
8632 if (!description_field) {
8633 description_field = current_field;
8634 }
8635 if (current_field->flag_occurs
8636 && !has_relative_pos (current_field)) {
8637 cb_error (_("relative LINE/COLUMN clause required with OCCURS"));
8638 }
8639 }
8640 /* ACUCOBOL-GT control definition */
8641 | level_number _entry_name
8642 {
8643 if (set_current_field ($1, $2)) {
8644 YYERROR;
8645 }
8646
8647 if (current_field->parent) {
8648 current_field->screen_foreg = current_field->parent->screen_foreg;
8649 current_field->screen_backg = current_field->parent->screen_backg;
8650 current_field->screen_prompt = current_field->parent->screen_prompt;
8651 }
8652 }
8653 control_definition
8654 {
8655 CB_PENDING ("GRAPHICAL CONTROL");
8656 }
8657 _control_attributes
8658 _screen_options /* FIXME: must be included in control_attributes */
8659 {
8660 cob_flags_t flags;
8661
8662 if (current_field->parent) {
8663 flags = current_field->parent->screen_flag;
8664 flags &= ~COB_SCREEN_BLANK_LINE;
8665 flags &= ~COB_SCREEN_BLANK_SCREEN;
8666 flags &= ~COB_SCREEN_ERASE_EOL;
8667 flags &= ~COB_SCREEN_ERASE_EOS;
8668 flags &= ~COB_SCREEN_LINE_PLUS;
8669 flags &= ~COB_SCREEN_LINE_MINUS;
8670 flags &= ~COB_SCREEN_COLUMN_PLUS;
8671 flags &= ~COB_SCREEN_COLUMN_MINUS;
8672
8673 flags = zero_conflicting_flags (current_field->screen_flag,
8674 flags);
8675
8676 current_field->screen_flag |= flags;
8677 }
8678
8679 if (current_field->screen_flag & COB_SCREEN_INITIAL) {
8680 if (!(current_field->screen_flag & COB_SCREEN_INPUT)) {
8681 cb_error (_("INITIAL specified on non-input field"));
8682 }
8683 }
8684 if (!qualifier) {
8685 current_field->flag_filler = 1;
8686 }
8687
8688 if (!description_field) {
8689 description_field = current_field;
8690 }
8691 if (current_field->flag_occurs
8692 && !has_relative_pos (current_field)) {
8693 cb_error (_("relative LINE/COLUMN clause required with OCCURS"));
8694 }
8695 cobc_cs_check = CB_CS_SCREEN;
8696 }
8697 /* entry for error recovery */
8698 | level_number error TOK_DOT
8699 {
8700 /*
8701 Tree associated with level number has already been freed; we don't
8702 need to do anything here.
8703 */
8704 yyerrok;
8705 cb_unput_dot ();
8706 check_pic_duplicate = 0;
8707 check_duplicate = 0;
8708 #if 1 /* RXWRXW Screen field */
8709 if (current_field) {
8710 current_field->flag_is_verified = 1;
8711 current_field->flag_invalid = 1;
8712 }
8713 #endif
8714 current_field = cb_get_real_field ();
8715 }
8716 ;
8717
8718 _screen_options:
8719 /* empty */
8720 | _screen_options screen_option
8721 ;
8722
8723 screen_option:
8724 BLANK LINE
8725 {
8726 set_screen_attr_with_conflict ("BLANK LINE", COB_SCREEN_BLANK_LINE,
8727 "BLANK SCREEN", COB_SCREEN_BLANK_SCREEN);
8728 }
8729 | BLANK SCREEN /* FIXME: this SCREEN is optional! */
8730 {
8731 set_screen_attr_with_conflict ("BLANK SCREEN", COB_SCREEN_BLANK_SCREEN,
8732 "BLANK LINE", COB_SCREEN_BLANK_LINE);
8733 }
8734 | BELL
8735 {
8736 set_screen_attr ("BELL", COB_SCREEN_BELL);
8737 }
8738 | BLINK
8739 {
8740 set_screen_attr ("BLINK", COB_SCREEN_BLINK);
8741 }
8742 | ERASE eol
8743 {
8744 set_screen_attr_with_conflict ("ERASE EOL", COB_SCREEN_ERASE_EOL,
8745 "ERASE EOS", COB_SCREEN_ERASE_EOS);
8746 }
8747 | ERASE eos
8748 {
8749 set_screen_attr_with_conflict ("ERASE EOS", COB_SCREEN_ERASE_EOS,
8750 "ERASE EOL", COB_SCREEN_ERASE_EOL);
8751 }
8752 | HIGHLIGHT
8753 {
8754 set_screen_attr_with_conflict ("HIGHLIGHT", COB_SCREEN_HIGHLIGHT,
8755 "LOWLIGHT", COB_SCREEN_LOWLIGHT);
8756 }
8757 | LOWLIGHT
8758 {
8759 set_screen_attr_with_conflict ("LOWLIGHT", COB_SCREEN_LOWLIGHT,
8760 "HIGHLIGHT", COB_SCREEN_HIGHLIGHT);
8761 }
8762 | STANDARD /* ACU extension to reset a group HIGH/LOW */
8763 {
8764 CB_PENDING ("STANDARD intensity");
8765 #if 0 /* in general we could simply remove high/low, but for syntax checks
8766 we still need a flag */
8767 set_screen_attr_with_conflict ("LOWLIGHT", COB_SCREEN_LOWLIGHT,
8768 "HIGHLIGHT", COB_SCREEN_HIGHLIGHT);
8769 #endif
8770 }
8771 | BACKGROUND_HIGH
8772 {
8773 CB_PENDING ("BACKGROUND intensity");
8774 }
8775 | BACKGROUND_LOW
8776 {
8777 CB_PENDING ("BACKGROUND intensity");
8778 }
8779 | BACKGROUND_STANDARD
8780 {
8781 CB_PENDING ("BACKGROUND intensity");
8782 }
8783 | reverse_video
8784 {
8785 set_screen_attr ("REVERSE-VIDEO", COB_SCREEN_REVERSE);
8786 }
8787 | SIZE _is_equal integer
8788 {
8789 /* set_screen_attr ("SIZE", COB_SCREEN_SIZE); */
8790 CB_PENDING ("SIZE clause");
8791 current_field->size = cb_get_int ($3);
8792 }
8793 | SIZE _is_equal numeric_identifier
8794 {
8795 CB_PENDING (_("screen positions from data-item"));
8796 }
8797 | CSIZE _is_equal numeric_identifier
8798 {
8799 CB_PENDING (_("screen positions from data-item"));
8800 CB_PENDING ("SIZE clause");
8801 }
8802 | CSIZE _is_equal integer
8803 {
8804 /* set_screen_attr ("SIZE", COB_SCREEN_SIZE); */
8805 CB_PENDING ("SIZE clause");
8806 current_field->size = cb_get_int ($3);
8807 }
8808 | UNDERLINE
8809 {
8810 set_screen_attr ("UNDERLINE", COB_SCREEN_UNDERLINE);
8811 }
8812 | OVERLINE
8813 {
8814 set_screen_attr ("OVERLINE", COB_SCREEN_OVERLINE);
8815 CB_PENDING ("OVERLINE");
8816 }
8817 | GRID
8818 {
8819 set_screen_attr ("GRID", COB_SCREEN_GRID);
8820 CB_PENDING ("GRID");
8821 }
8822 | LEFTLINE
8823 {
8824 set_screen_attr ("LEFTLINE", COB_SCREEN_LEFTLINE);
8825 CB_PENDING ("LEFTLINE");
8826 }
8827 | AUTO
8828 {
8829 set_screen_attr_with_conflict ("AUTO", COB_SCREEN_AUTO,
8830 "TAB", COB_SCREEN_TAB);
8831 }
8832 | TAB
8833 {
8834 set_screen_attr_with_conflict ("TAB", COB_SCREEN_TAB,
8835 "AUTO", COB_SCREEN_AUTO);
8836 }
8837 | SECURE
8838 {
8839 set_screen_attr_with_conflict ("SECURE", COB_SCREEN_SECURE,
8840 "NO-ECHO", COB_SCREEN_NO_ECHO);
8841 }
8842 | no_echo
8843 {
8844 if (cb_no_echo_means_secure) {
8845 set_screen_attr ("SECURE", COB_SCREEN_SECURE);
8846 } else {
8847 set_screen_attr_with_conflict ("NO-ECHO", COB_SCREEN_NO_ECHO,
8848 "SECURE", COB_SCREEN_SECURE);
8849 }
8850 }
8851 | REQUIRED
8852 {
8853 set_screen_attr ("REQUIRED", COB_SCREEN_REQUIRED);
8854 }
8855 | FULL
8856 {
8857 set_screen_attr ("FULL", COB_SCREEN_FULL);
8858 }
8859 | PROMPT CHARACTER _is id_or_lit
8860 {
8861 /* FIXME: ACUCOBOL and (undocumented) MF have CHARACTER as optional here */
8862 set_screen_attr ("PROMPT", COB_SCREEN_PROMPT);
8863 current_field->screen_prompt = $4;
8864 }
8865 | PROMPT
8866 {
8867 set_screen_attr ("PROMPT", COB_SCREEN_PROMPT);
8868 }
8869 | TOK_INITIAL
8870 {
8871 set_screen_attr ("INITIAL", COB_SCREEN_INITIAL);
8872 }
8873 | LINE screen_line_number
8874 {
8875 check_repeated ("LINE", SYN_CLAUSE_16, &check_pic_duplicate);
8876 }
8877 | LINES _is_equal control_size
8878 {
8879 CB_PENDING ("LINES clause"); /* note: should only occur with controls */
8880 }
8881 | CLINE screen_line_number
8882 {
8883 /*check_repeated ("CLINE", SYN_CLAUSE_5000, &check_pic_duplicate);*/
8884 }
8885 | column_or_col_or_position_or_pos screen_col_number
8886 {
8887 check_repeated ("COLUMN", SYN_CLAUSE_17, &check_pic_duplicate);
8888 }
8889 | CCOL screen_col_number
8890 {
8891 /*check_repeated ("CCOL", SYN_CLAUSE_5001, &check_pic_duplicate);*/
8892 }
8893 | COLOR _is num_id_or_lit
8894 {
8895 #if 0 /* TODO: implement, and add reverse to BACKGROUND/FOREGROUND-COLOR */
8896 check_repeated ("COLOR", SYN_CLAUSE_19, &check_pic_duplicate);
8897 set_screen_attr_with_conflict ("COLOR", COB_SCREEN_COLOR,
8898 "BACKGROUND-COLOR", COB_SCREEN_BACKGROUND_COLOR);
8899 set_screen_attr_with_conflict ("COLOR", COB_SCREEN_COLOR,
8900 "FOREGROUND-COLOR", FOREGROUND_COLOR);
8901 #endif
8902 CB_PENDING ("COLOR clause");
8903 }
8904 | FOREGROUND_COLOR _is num_id_or_lit
8905 {
8906 check_repeated ("FOREGROUND-COLOR", SYN_CLAUSE_18, &check_pic_duplicate);
8907 current_field->screen_foreg = $3;
8908 }
8909 | BACKGROUND_COLOR _is num_id_or_lit
8910 {
8911 check_repeated ("BACKGROUND-COLOR", SYN_CLAUSE_19, &check_pic_duplicate);
8912 current_field->screen_backg = $3;
8913 }
8914 | usage_clause
8915 /* FIXME shift/reduce conflict with control_attributes
8916 | type_to_clause
8917 */
8918 | blank_clause
8919 | screen_global_clause
8920 | justified_clause
8921 | sign_clause
8922 | value_clause
8923 | picture_clause
8924 | screen_occurs_clause
8925 | USING identifier
8926 {
8927 $$ = check_not_88_level ($2);
8928
8929 check_repeated ("USING", SYN_CLAUSE_20, &check_pic_duplicate);
8930 current_field->screen_from = $$;
8931 current_field->screen_to = $$;
8932 current_field->screen_flag |= COB_SCREEN_INPUT;
8933 }
8934 | FROM from_parameter
8935 {
8936 check_repeated ("FROM", SYN_CLAUSE_21, &check_pic_duplicate);
8937 current_field->screen_from = $2;
8938 }
8939 | TO identifier
8940 {
8941 $$ = check_not_88_level ($2);
8942
8943 check_repeated ("TO", SYN_CLAUSE_22, &check_pic_duplicate);
8944 current_field->screen_to = $$;
8945 current_field->screen_flag |= COB_SCREEN_INPUT;
8946 }
8947 ;
8948
8949 control_definition:
8950 control_type_name
8951 | OBJECT control_type
8952 {
8953 cobc_cs_check |= CB_CS_GRAPHICAL_CONTROL;
8954 }
8955 ;
8956
8957 control_type_name:
8958 LABEL /* CTL-LABEL -> 01 */
8959 | ENTRY_FIELD /* CTL-ENTRY-FIELD -> 02 */
8960 | PUSH_BUTTON /* CTL-PUSH-BUTTON -> 03 */
8961 | CHECK_BOX /* CTL-CHECK-BOX -> 04 */
8962 | RADIO_BUTTON /* CTL-RADIO-BUTTON -> 05 */
8963 | SCROLL_BAR /* CTL-SCROLL-BAR -> 06 */
8964 | LIST_BOX /* CTL-LIST-BOX -> 07 */
8965 | COMBO_BOX /* CTL-COMBO-BOX -> 08 */
8966 | FRAME /* CTL-FRAME -> 09 */
8967 /* disabled for now, conflicts with display attribute
8968 | TAB /* CTL-TAB -> 10 */
8969 | BAR /* CTL-BAR -> 11 */
8970 /* disabled for now, conflicts with display attribute
8971 | GRID /* CTL-GRID -> 12 */
8972 | BITMAP /* CTL-BITMAP -> 13 */
8973 | TREE_VIEW /* CTL-TREE-VIEW -> 14 */
8974 | WEB_BROWSER /* CTL-WEB-BROWSER -> 15 */
8975 | ACTIVEX /* CTL-ACTIVE-X -> 16 */
8976 | STATUS_BAR /* CTL-STATUS-BAR -> 17 */
8977 | DATE_ENTRY /* CTL-DATE-ENTRY -> 18 */
8978 /* | _NET /* check recent controls.def,
8979 define styles and properties, too */
8980 ;
8981
8982 /* note: these match to the control_type_names, see comments there */
8983 control_type:
8984 integer
8985 | identifier
8986 ;
8987
8988 /* items that are assigned to a control */
8989 control_item:
8990 identifier /* may be defined in SCREEN SECTION or a handle */
8991 | CONTROL /* the actual control is defined by AT, LINE, COLUMN, CLINE, and CCOL */
8992 ;
8993
8994 _control_attributes:
8995 /* empty */
8996 | control_attributes
8997 ;
8998
8999 control_attributes:
9000 control_attribute
9001 | control_attributes control_attribute
9002 ;
9003
9004 control_attribute:
9005 control_style
9006 | control_property _is_are_equal x_list
9007 ;
9008
9009 control_style:
9010 STYLE _is_equal control_style_type
9011 | _flag_not control_style_name
9012 ;
9013
9014 control_property:
9015 PROPERTY control_property_type
9016 | control_property_name
9017 ;
9018
9019 control_style_name:
9020 control_style_name_generic
9021 | control_style_name_label
9022 | control_style_name_entry_field
9023 | control_style_name_push_button
9024 | control_style_name_check_box
9025 /*| control_style_name_radio_button */
9026 /*| control_style_name_scroll_bar */
9027 | control_style_name_list_box
9028 | control_style_name_combo_box
9029 | control_style_name_frame
9030 | control_style_name_tab_control
9031 | control_style_name_bar
9032 /*| control_style_name_bitmap */
9033 | control_style_name_grid
9034 | control_style_name_tree_view
9035 /*| control_style_name_web_browser */
9036 | control_style_name_activex
9037 | control_style_name_date_entry
9038 ;
9039
9040 control_property_name:
9041 control_property_name_generic
9042 | control_property_name_label
9043 | control_property_name_entry_field
9044 | control_property_name_push_button
9045 /*| control_property_name_check_box <- duplicated from push_button */
9046 | control_property_name_radio_button
9047 /*| control_property_name_scroll_bar <- duplicated from radio_button */
9048 | control_property_name_list_box
9049 /*| control_property_name_combo_box <- duplicated from list_box */
9050 | control_property_name_frame
9051 | control_property_name_tab_control
9052 | control_property_name_bar
9053 | control_property_name_bitmap
9054 | control_property_name_grid
9055 | control_property_name_tree_view
9056 | control_property_name_web_browser
9057 | control_property_name_activex
9058 | control_property_name_date_entry
9059 ;
9060
9061
9062 /* Generic style and property names that apply to several types of controls */
9063 control_style_name_generic:
9064 PERMANENT /* S-PERMANENT --> 1073741824 */
9065 | TEMPORARY /* S-TEMPORARY --> 536870912 */
9066 | NOTAB /* S-NOTAB --> 268435456 */
9067 | HEIGHT_IN_CELLS /* S-HEIGHT-IN-CELLS --> 134217728 */
9068 | WIDTH_IN_CELLS /* S-WIDTH-IN-CELLS --> 67108864 */
9069 | THREEDIMENSIONAL /* S-3D --> 33554432 */
9070 | OVERLAP_LEFT /* S-OVERLAP-LEFT --> 16777216 */
9071 | OVERLAP_TOP /* S-OVERLAP-TOP --> 8388608 */
9072 | SELF_ACT /* S-SELF-ACT --> 4194304 */
9073 | NOTIFY /* S-NOTIFY --> 2097152 */
9074 ;
9075
9076 control_property_name_generic:
9077 TERMINATION_VALUE /* P-TERMINATION-VALUE --> 1 */
9078 | EXCEPTION_VALUE /* P-EXCEPTION-VALUE --> 2 */
9079 ;
9080
9081 /* LABEL style and property names */
9082 control_style_name_label:
9083 LEFT /* LS-LEFT --> 1 */
9084 | RIGHT /* LS-RIGHT --> 2 */
9085 | CENTER /* LS-CENTER --> 4 */
9086 | NO_KEY_LETTER /* LS-NO-KEY-LETTER --> 8 */
9087 | TRANSPARENT /* LS-TRANSPARENT --> 16 */
9088 ;
9089
9090 control_property_name_label:
9091 LABEL_OFFSET /* LP-LABEL-OFFSET --> 1 */
9092 ;
9093
9094 /* ENTRY-FIELD style and property names */
9095 control_style_name_entry_field:
9096 /* LEFT /* EFS-LEFT --> 1 */
9097 /*| RIGHT /* EFS-RIGHT --> 2 */
9098 /*| CENTER /* EFS-CENTER --> 4 */
9099 /*|*/ BOX /* EFS-BOX --> 8 */
9100 | NO_BOX /* EFS-NO-BOX --> 16 */
9101 | MULTILINE /* EFS-MULTILINE --> 32 */
9102 | VSCROLL /* EFS-VSCROLL --> 96 */
9103 | VSCROLL_BAR /* EFS-VSCROLL-BAR --> 224 */
9104 | USE_RETURN /* EFS-USE-RETURN --> 256 */
9105 | USE_TAB /* EFS-USE-TAB --> 512 */
9106 | UPPER /* EFS-UPPER --> 1024 */
9107 | LOWER /* EFS-LOWER --> 2048 */
9108 | NO_AUTOSEL /* EFS-NO-AUTOSEL --> 4096 */
9109 | READ_ONLY /* EFS-READ-ONLY --> 8192 */
9110 /*| AUTO /* EFS-AUTOTERMINATE --> 16384 */
9111 | NOTIFY_CHANGE /* EFS-NOTIFY-CHANGE --> 32768 */
9112 /*| SECURE /* EFS-SECURE --> 65536 */
9113 | NUMERIC /* EFS-NUMERIC --> 131072 */
9114 | SPINNER /* EFS-SPINNER --> 262144 */
9115 | AUTO_SPIN /* EFS-AUTO-SPIN --> 262208 */
9116 ;
9117
9118 control_property_name_entry_field:
9119 MAX_TEXT /* EFP-MAX-TEXT --> 3 */
9120 | MAX_LINES /* EFP-MAX-LINES --> 4 */
9121 | MIN_VAL /* EFP-MIN-VAL --> 5 */
9122 | MAX_VAL /* EFP-MAX-VAL --> 6 */
9123 | AUTO_DECIMAL /* EFP-AUTO-DECIMAL --> 7 */
9124 | CURSOR_ROW /* EFP-CURSOR-ROW --> 8 */
9125 | CURSOR /* EFP-CURSOR --> 4097 */
9126 | ACTION /* EFP-ACTION --> 4098 */
9127 | SELECTION_TEXT /* EFP-SELECTION-TEXT --> 4099 */
9128 | CURSOR_COL /* EFP-CURSOR-COL --> 4100 */
9129 ;
9130
9131 /* PUSH-BUTTON style and property names */
9132 control_style_name_push_button:
9133 DEFAULT_BUTTON /* PBS-DEFAULT-BUTTON --> 1 */
9134 | ESCAPE_BUTTON /* PBS-ESCAPE-BUTTON --> 2 */
9135 | OK_BUTTON /* PBS-OK-BUTTON --> 4 */
9136 | CANCEL_BUTTON /* PBS-CANCEL-BUTTON --> 8 */
9137 | NO_AUTO_DEFAULT /* PBS-NO-AUTO-DEFAULT --> 16 */
9138 | BITMAP /* PBS-BITMAP --> 32768 */
9139 | SQUARE /* PBS-SQUARE --> 16384 */
9140 | FRAMED /* PBS-FRAMED --> 8192 */
9141 | UNFRAMED /* PBS-UNFRAMED --> 4096 */
9142 | FLAT /* PBS-FLAT --> 2048 */
9143 /*| MULTILINE /* PBS-MULTILINE --> 1024 */
9144 ;
9145
9146 control_property_name_push_button:
9147 BITMAP_NUMBER /* PBP-BITMAP-NUMBER --> 3 */
9148 | BITMAP_HANDLE /* PBP-BITMAP-HANDLE --> 4 */
9149 ;
9150
9151 /* CHECK-BOX style and property names */
9152 control_style_name_check_box:
9153 /* BITMAP /* CBS-BITMAP --> 32768 */
9154 /*| SQUARE /* CBS-SQUARE --> 16384 */
9155 /*| FRAMED /* CBS-FRAMED --> 8192 */
9156 /*| UNFRAMED /* CBS-UNFRAMED --> 4096 */
9157 /*| FLAT /* CBS-FLAT --> 2048 */
9158 /*| MULTILINE /* CBS-MULTILINE --> 1024 */
9159 VTOP /* CBS-VTOP --> 512 */
9160 | LEFT_TEXT /* CBS-LEFT-TEXT --> 2 */
9161 ;
9162
9163 /*control_property_name_check_box:
9164 /* BITMAP_NUMBER /* CBP-BITMAP-NUMBER --> 3 */
9165 /*| BITMAP_HANDLE /* CBP-BITMAP-HANDLE --> 4 */
9166 /*;
9167
9168 /* RADIO-BUTTON style and property names */
9169 /*control_style_name_radio_button:
9170 /* NO_GROUP_TAB /* RBS-NO-GROUP-TAB --> 1 */
9171 /*| LEFT_TEXT /* RBS-LEFT-TEXT --> 2 */
9172 /*| BITMAP /* RBS-BITMAP --> 32768 */
9173 /*| SQUARE /* RBS-SQUARE --> 16384 */
9174 /*| FRAMED /* RBS-FRAMED --> 8192 */
9175 /*| UNFRAMED /* RBS-UNFRAMED --> 4096 */
9176 /*| FLAT /* RBS-FLAT --> 2048 */
9177 /*| MULTILINE /* RBS-MULTILINE --> 1024 */
9178 /*| VTOP /* RBS-VTOP --> 512 */
9179 /*;*/
9180
9181 control_property_name_radio_button:
9182 /* BITMAP_NUMBER /* RBP-BITMAP-NUMBER --> 3 */
9183 /*| BITMAP_HANDLE /* RBP-BITMAP-HANDLE --> 4 */
9184 GROUP /* RBP-GROUP --> 5 */
9185 | GROUP_VALUE /* RBP-GROUP-VALUE --> 6 */
9186 ;
9187
9188 /* SCROLL-BAR style and property names */
9189 /*control_style_name_scroll_bar:
9190 /* NO_GROUP_TAB /* SBS-HORIZONTAL --> 1 */
9191 /*| LEFT_TEXT /* SBS-TRACK-THUMB --> 2 */
9192 /*; */
9193
9194 /*control_property_name_scroll_bar:
9195 /* BITMAP_NUMBER /* SBP-MIN-VAL --> 1 */
9196 /*| BITMAP_HANDLE /* SBP-MAX-VAL --> 2 */
9197 /*| GROUP /* SBP-PAGE-SIZE --> 3 */
9198 /*;*/
9199
9200 /* LIST-BOX style and property names */
9201 control_style_name_list_box:
9202 UNSORTED /* LBS-UNSORTED --> 1 */
9203 /*| NO_BOX /* LBS-NO-BOX --> 2 */
9204 /*| BOX /* LBS-BOX --> 4 */
9205 | NOTIFY_DBLCLICK /* LBS-NOTIFY-DBLCLICK --> 256 */
9206 | NOTIFY_SELCHANGE /* LBS-NOTIFY-SELCHANGE --> 512 */
9207 | PAGED /* LBS-PAGED --> 1024 */
9208 /*| UPPER /* LBS-UPPER --> 2048 */
9209 /*| LOWER /* LBS-LOWER --> 4096 */
9210 | NO_SEARCH /* LBS-NO-SEARCH --> 8192 */
9211 ;
9212
9213 control_property_name_list_box:
9214 MASS_UPDATE /* LBP-MASS-UPDATE --> 3 */
9215 | INSERTION_INDEX /* LBP-INSERTION-INDEX --> 4 */
9216 | DATA_COLUMNS /* LBP-DATA-COLUMNS --> 5 */
9217 | DISPLAY_COLUMNS /* LBP-DISPLAY-COLUMNS --> 6 */
9218 | QUERY_INDEX /* LBP-QUERY-INDEX --> 7 */
9219 | ALIGNMENT /* LBP-ALIGNMENT --> 8 */
9220 | SEPARATION /* LBP-SEPARATION --> 9 */
9221 | DIVIDERS /* LBP-DIVIDERS --> 10 */
9222 | SORT_ORDER /* LBP-SORT-ORDER --> 11 */
9223 | ITEM_TO_ADD /* LBP-ITEM-TO-ADD --> 4097 */
9224 | RESET_LIST /* LBP-RESET-LIST --> 4098 */
9225 | ITEM_TO_DELETE /* LBP-ITEM-TO-DELETE --> 4099 */
9226 | SEARCH_TEXT /* LBP-SEARCH-TEXT --> 4100 */
9227 | SELECTION_INDEX /* LBP-SELECTION-INDEX --> 4103 */
9228 | ITEM_VALUE /* LBP-ITEM-VALUE --> 4104 */
9229 | THUMB_POSITION /* LBP-THUMB-POSITION --> 4105 */
9230 ;
9231
9232 /* COMBO-BOX style and property names */
9233 control_style_name_combo_box:
9234 /* UNSORTED /* CMS-UNSORTED --> 1 */
9235 DROP_DOWN /* CMS-DROP-DOWN --> 0 */
9236 | STATIC_LIST /* CMS-STATIC-LIST --> 2 */
9237 | DROP_LIST /* CMS-DROP-LIST --> 4 */
9238 /*| BOX /* CMS-BOX --> 8 */
9239 /*| NO_BOX /* CMS-NO-BOX --> 16 */
9240 /*| NOTIFY_DBLCLICK /* CMS-NOTIFY-DBLCLICK --> 256 */
9241 /*| NOTIFY_SELCHANGE /* CMS-NOTIFY-SELCHANGE --> 512 */
9242 /*| UPPER /* CMS-UPPER --> 2048 */
9243 /*| LOWER /* CMS-LOWER --> 4096 */
9244 ;
9245
9246 /*control_property_name_combo_box:
9247 /* MASS_UPDATE /* CMP-MASS-UPDATE --> 3 */
9248 /*| MAX_TEXT /* CMP-MAX-TEXT --> 4 */
9249 /*| INSERTION_INDEX /* CMP-INSERTION-INDEX --> 5 */
9250 /*| ITEM_TO_ADD /* CMP-ITEM-TO-ADD --> 4097 */
9251 /*| RESET_LIST /* CMP-RESET-LIST --> 4098 */
9252 /*| ITEM_TO_DELETE /* CMP-ITEM-TO-DELETE --> 4099 */
9253 /*;*/
9254
9255 /* FRAME style and property names */
9256 control_style_name_frame:
9257 RAISED /* FS-RAISED --> 1 */
9258 | LOWERED /* FS-LOWERED --> 2 */
9259 | ENGRAVED /* FS-ENGRAVED --> 4 */
9260 | RIMMED /* FS-RIMMED --> 8 */
9261 | HEAVY /* FS-HEAVY --> 16 */
9262 | VERY_HEAVY /* FS-VERY-HEAVY --> 32 */
9263 | ALTERNATE /* FS-ALTERNATE --> 64 */
9264 | FULL_HEIGHT /* FS-FULL-HEIGHT --> 128 */
9265 ;
9266
9267 control_property_name_frame:
9268 HIGH_COLOR /* FP-HIGH-COLOR --> 1 */
9269 | LOW_COLOR /* FP-LOW-COLOR --> 2 */
9270 | FILL_COLOR /* FP-FILL-COLOR --> 3 */
9271 | FILL_PERCENT /* FP-FILL-PERCENT --> 4 */
9272 | FILL_COLOR2 /* FP-FILL-COLOR2 --> 5 */
9273 | TITLE_POSITION /* FP-TITLE-POSITION --> 6 */
9274 ;
9275
9276 /* TAB-CONTROL style and property names */
9277 control_style_name_tab_control:
9278 /* MULTILINE /* TS-MULTILINE --> 1 */
9279 BUTTONS /* TS-BUTTONS --> 2 */
9280 | FIXED_WIDTH /* TS-FIXED-WIDTH --> 4 */
9281 | BOTTOM /* TS-BOTTOM --> 8 */
9282 | VERTICAL /* TS-VERTICAL --> 17 */
9283 | FLAT_BUTTONS /* TS-FLAT-BUTTONS --> 32 */
9284 | HOT_TRACK /* TS-HOT-TRACK --> 64 */
9285 | NO_DIVIDERS /* TS-NO-DIVIDERS --> 128 */
9286 | NO_FOCUS /* TS-NO-FOCUS --> 256 */
9287 ;
9288
9289 control_property_name_tab_control:
9290 /* BITMAP_HANDLE /* TP-BITMAP-HANDLE --> 1 */
9291 BITMAP_WIDTH /* TP-BITMAP-WIDTH --> 2 */
9292 /*| BITMAP_NUMBER /* TP-BITMAP-NUMBER --> 3 */
9293 | TAB_TO_ADD /* TP-TAB-TO-ADD --> 4097 */
9294 | RESET_TABS /* TP-RESET-TABS --> 4098 */
9295 | TAB_TO_DELETE /* TP-TAB-TO-DELETE --> 4099 */
9296 ;
9297
9298 /* BAR style and property names */
9299 control_style_name_bar:
9300 DOTTED /* BRS-DOTTED --> 1 */
9301 | DASHED /* BRS-DASHED --> 2 */
9302 | DOTDASH /* BRS-DOTDASH --> 3 */
9303 ;
9304
9305 control_property_name_bar:
9306 WIDTH /* BRP-WIDTH --> 1 */
9307 | COLORS /* BRP-COLORS --> 2 */
9308 | SHADING /* BRP-SHADING --> 3 */
9309 | POSITION_SHIFT /* BRP-POSITION-SHIFT --> 4 */
9310 | LEADING_SHIFT /* BRP-LEADING-SHIFT --> 5 */
9311 | TRAILING_SHIFT /* BRP-TRAILING-SHIFT --> 6 */
9312 ;
9313
9314 /* BITMAP style and property names */
9315 /*control_style_name_bitmap:
9316 /* COBOL /* just use as place holder, no styles here */
9317 /*;*/
9318
9319 control_property_name_bitmap:
9320 /* BITMAP_NUMBER /* BTP-BITMAP-NUMBER --> 1 */
9321 /*| BITMAP_HANDLE /* BTP-BITMAP-HANDLE --> 2 */
9322 BITMAP_START /* BTP-BITMAP-START --> 3 */
9323 | BITMAP_END /* BTP-BITMAP-END --> 4 */
9324 | BITMAP_TIMER /* BTP-BITMAP-TIMER --> 5 */
9325 | BITMAP_TRANSPARENT_COLOR /* BTP-BITMAP-TRANSPARENT-COLOR --> 6 */
9326 ;
9327
9328 /* GRID style and property names */
9329 control_style_name_grid:
9330 BOXED /* TGRS-BOXED --> 1 */
9331 /*| NO_BOX /* TGRS-NO-BOX --> 2 */
9332 /*| VSCROLL /* TGRS-VSCROLL --> 4 */
9333 | HSCROLL /* TGRS-HSCROLL --> 8 */
9334 | COLUMN_HEADINGS /* TGRS-COLUMN-HEADINGS --> 16 */
9335 | ROW_HEADINGS /* TGRS-ROW-HEADINGS --> 32 */
9336 | TILED_HEADINGS /* TGRS-TILED-HEADINGS --> 64 */
9337 | CENTERED_HEADINGS /* TGRS-CENTERED-HEADINGS --> 128 */
9338 /*| USE_TAB /* TGRS-USE-TAB --> 256 */
9339 | ADJUSTABLE_COLUMNS /* TGRS-ADJUSTABLE-COLUMNS --> 512 */
9340 /*| PAGED /* TGRS-PAGED --> 1024 */
9341 ;
9342
9343 control_property_name_grid:
9344 ROW_DIVIDERS /* GRP-ROW-DIVIDERS --> 1 */
9345 | VPADDING /* GRP-VPADDING --> 2 */
9346 | DIVIDER_COLOR /* GRP-DIVIDER-COLOR --> 3 */
9347 /*| INSERTION_INDEX /* GRP-INSERTION-INDEX --> 4 */
9348 /*| DATA_COLUMNS /* GRP-DATA-COLUMNS --> 5 */
9349 /*| DISPLAY_COLUMNS /* GRP-DISPLAY-COLUMNS --> 6 */
9350 /*| ALIGNMENT /* GRP-ALIGNMENT --> 7 */
9351 /*| SEPARATION /* GRP-SEPARATION --> 8 */
9352 | COLUMN_DIVIDERS /* GRP-COLUMN-DIVIDERS --> 9 */
9353 | ROW_COLOR_PATTERN /* GRP-ROW-COLOR-PATTERN --> 10 */
9354 | Y /* GRP-Y --> 11 */
9355 | X /* GRP-X --> 12 */
9356 | COLUMN_COLOR /* GRP-COLUMN-COLOR --> 13 */
9357 | ROW_COLOR /* GRP-ROW-COLOR --> 14 */
9358 | CELL_COLOR /* GRP-CELL-COLOR --> 15 */
9359 | COLUMN_FONT /* GRP-COLUMN-FONT --> 16 */
9360 | ROW_FONT /* GRP-ROW-FONT --> 17 */
9361 | CELL_FONT /* GRP-CELL-FONT --> 18 */
9362 /*| BITMAP /* GRP-BITMAP --> 19 */
9363 /*| BITMAP_NUMBER /* GRP-BITMAP-NUMBER --> 20 */
9364 /*| BITMAP_WIDTH /* GRP-BITMAP-WIDTH --> 21 */
9365 | BITMAP_TRAILING /* GRP-BITMAP-TRAILING --> 22 */
9366 | NUM_ROWS /* GRP-NUM-ROWS --> 23 */
9367 | CURSOR_Y /* GRP-CURSOR-Y --> 24 */
9368 | CURSOR_X /* GRP-CURSOR-X --> 25 */
9369 | CURSOR_FRAME_WIDTH /* GRP-CURSOR-FRAME-WIDTH --> 26 */
9370 | VIRTUAL_WIDTH /* GRP-VIRTUAL-WIDTH --> 27 */
9371 | DATA_TYPES /* GRP-DATA-TYPES --> 28 */
9372 | CURSOR_COLOR /* GRP-CURSOR-COLOR --> 29 */
9373 | HEADING_COLOR /* GRP-HEADING-COLOR --> 30 */
9374 | HEADING_FONT /* GRP-HEADING-FONT --> 31 */
9375 | HEADING_DIVIDER_COLOR /* GRP-HEADING-DIVIDER-COLOR --> 32 */
9376 | START_X /* GRP-START-X --> 33 */
9377 | START_Y /* GRP-START-Y --> 34 */
9378 | REGION_COLOR /* GRP-REGION-COLOR --> 35 */
9379 /*| MASS_UPDATE /* GRP-MASS-UPDATE --> 36 */
9380 | HIDDEN_DATA /* GRP-HIDDEN-DATA --> 37 */
9381 | END_COLOR /* GRP-END-COLOR --> 38 */
9382 | FILE_POS /* GRP-FILE-POS --> 39 */
9383 | NUM_COL_HEADINGS /* GRP-NUM-COL-HEADINGS --> 40 */
9384 | DRAG_COLOR /* GRP-DRAG-COLOR --> 41 */
9385 | FINISH_REASON /* GRP-FINISH-REASON --> 42 */
9386 | COLUMN_PROTECTION /* GRP-COLUMN-PROTECTION --> 43 */
9387 | ROW_PROTECTION /* GRP-ROW-PROTECTION --> 44 */
9388 | CELL_PROTECTION /* GRP-CELL-PROTECTION --> 45 */
9389 | RECORD_TO_ADD /* GRP-RECORD-TO-ADD --> 4097 */
9390 | RESET_GRID /* GRP-RESET-GRID --> 4098 */
9391 | CELL_DATA /* GRP-CELL-DATA --> 4099 */
9392 | RECORD_TO_DELETE /* GRP-RECORD-TO-DELETE --> 4100 */
9393 | RECORD_DATA /* GRP-RECORD-DATA --> 4101 */
9394 | LAST_ROW /* GRP-LAST-ROW --> 4102 */
9395 | VSCROLL_POS /* GRP-VSCROLL-POS --> 4103 */
9396 | HSCROLL_POS /* GRP-HSCROLL-POS --> 4104 */
9397 /*| ACTION /* GRP-ACTION --> 4105 */
9398 /*| SEARCH_TEXT /* GRP-SEARCH-TEXT --> 4106 */
9399 | SEARCH_OPTIONS /* GRP-SEARCH-OPTIONS --> 4107 */
9400 | INSERT_ROWS /* GRP-INSERT-ROWS --> 4108 */
9401 | ENTRY_REASON /* GRP-ENTRY-REASON --> 4109 */
9402 ;
9403
9404 /* TREE-VIEW style and property names */
9405 control_style_name_tree_view:
9406 /* BOXED /* TVS-BOXED --> 1 */
9407 /*| NO_BOX /* TVS-NO-BOX --> 2 */
9408 /*| BUTTONS /* TVS-BUTTONS --> 4 */
9409 SHOW_LINES /* TVS-SHOW-LINES --> 8 */
9410 | LINES_AT_ROOT /* TVS-LINES-AT-ROOT --> 16 */
9411 | SHOW_SEL_ALWAYS /* TVS-SHOW-SEL-ALWAYS --> 32 */
9412 ;
9413
9414 control_property_name_tree_view:
9415 PARENT /* TVP-PARENT --> 1 */
9416 | PLACEMENT /* TVP-PLACEMENT --> 2 */
9417 | ITEM /* TVP-ITEM --> 3 */
9418 /*| BITMAP_HANDLE /* TVP-BITMAP-HANDLE --> 4 */
9419 /*| BITMAP_WIDTH /* TVP-BITMAP-WIDTH --> 5 */
9420 /*| ITEM_TO_ADD /* TVP-ITEM-TO-ADD --> 4097 */
9421 | ITEM_TEXT /* TVP-ITEM-TEXT --> 4098 */
9422 | NEXT_ITEM /* TVP-NEXT-ITEM --> 4099 */
9423 /*| ITEM_TO_DELETE /* TVP-ITEM-TO-DELETE --> 4100 */
9424 /*| RESET_LIST /* TVP-RESET-LIST --> 4101 */
9425 | ENSURE_VISIBLE /* TVP-ENSURE-VISIBLE --> 4102 */
9426 | EXPAND /* TVP-EXPAND --> 4103 */
9427 | ITEM_TO_EMPTY /* TVP-ITEM-TO-EMPTY --> 4104 */
9428 /*| BITMAP_NUMBER /* TVP-BITMAP-NUMBER --> 4105 */
9429 /*| HIDDEN_DATA /* TVP-HIDDEN-DATA --> 4106 */
9430 | HAS_CHILDREN /* TVP-HAS-CHILDREN --> 4107 */
9431 ;
9432
9433 /* WEB-BROWSER style and property names */
9434 /*control_style_name_web_browser:
9435 /* NOTIFY_CHANGE /* WBS-NOTIFY-CHANGE --> 1 */
9436 /*;*/
9437
9438 control_property_name_web_browser:
9439 BUSY /* WBP-BUSY --> 1 */
9440 | TYPE /* WBP-TYPE --> 2 */
9441 | STATUS_TEXT /* WBP-STATUS-TEXT --> 3 */
9442 | NAVIGATE_URL /* WBP-NAVIGATE-URL --> 4 */
9443 | PROGRESS /* WBP-PROGRESS --> 5 */
9444 | MAX_PROGRESS /* WBP-MAX-PROGRESS --> 6 */
9445 | CUSTOM_PRINT_TEMPLATE /* WBP-CUSTOM-PRINT-TEMPLATE --> 7 */
9446 | FILE_NAME /* WBP-FILE-NAME --> 8 */
9447 | GO_BACK /* WBP-GO-BACK --> 4097 */
9448 | GO_FORWARD /* WBP-GO-FORWARD --> 4098 */
9449 | GO_HOME /* WBP-GO-HOME --> 4099 */
9450 | GO_SEARCH /* WBP-GO-SEARCH --> 4100 */
9451 | REFRESH /* WBP-REFRESH --> 4101 */
9452 /*| STOP WBP-STOP --> 4102 */
9453 | PRINT /* WBP-PRINT --> 4103 */
9454 | PRINT_NO_PROMPT /* WBP-PRINT-NO-PROMPT --> 4104 */
9455 | PRINT_PREVIEW /* WBP-PRINT-PREVIEW --> 4105 */
9456 | PAGE_SETUP /* WBP-PAGE-SETUP --> 4106 */
9457 | SAVE_AS /* WBP-SAVE-AS --> 4107 */
9458 | SAVE_AS_NO_PROMPT /* WBP-SAVE-AS-NO-PROMPT --> 4108 */
9459 | PROPERTIES /* WBP-PROPERTIES --> 4109 */
9460 | COPY_SELECTION /* WBP-COPY-SELECTION --> 4110 */
9461 | SELECT_ALL /* WBP-SELECT-ALL --> 4111 */
9462 | CLEAR_SELECTION /* WBP-CLEAR-SELECTION --> 4112 */
9463 ;
9464
9465 /* ACTIVE-X style and property names */
9466 control_style_name_activex:
9467 /* USE_RETURN /* AXS-USE-RETURN --> 256 */
9468 /*| USE_TAB /* AXS-USE-TAB --> 512 */
9469 USE_ALT /* AXS-USE-ALT --> 1024 */
9470 ;
9471
9472 control_property_name_activex:
9473 EVENT_LIST /* AXP-EVENT-LIST --> 1 */
9474
9475 /* DATE-ENTRY style and property names */
9476 control_style_name_date_entry:
9477 SHORT_DATE /* DAS-SHORT-DATE --> 0 */
9478 | CENTURY_DATE /* DAS-CENTURY-DATE --> 1 */
9479 | LONG_DATE /* DAS-LONG-DATE --> 2 */
9480 | TIME /* DAS-TIME --> 3 */
9481 | NO_F4 /* DAS-NO-F4 --> 4 */
9482 | NO_UPDOWN /* DAS-NO-UPDOWN --> 8 */
9483 | RIGHT_ALIGN /* DAS-RIGHT-ALIGN --> 16 */
9484 | SHOW_NONE /* DAS-SHOW-NONE --> 32 */
9485 /*| NOTIFY_CHANGE /* DAS-NOTIFY-CHANGE --> 32768 */
9486 /*| SPINNER /* DAS-SPINNER --> 262144 */
9487 ;
9488
9489 control_property_name_date_entry:
9490 VALUE_FORMAT /* DAP-VALUE-FORMAT --> 1 */
9491 | CALENDAR_FONT /* DAP-CALENDAR-FONT --> 2 */
9492 | DISPLAY_FORMAT /* DAP-DISPLAY-FORMAT --> 4097 */
9493 ;
9494
9495 /* note: these match to the style_type_names, see comments there */
9496 control_style_type:
9497 integer
9498 | identifier
9499 ;
9500
9501 /* note: these match to the property_type_names, see comments there */
9502 control_property_type:
9503 integer
9504 /*| identifier /+ logic conflict because of _in_equal control_property_type */
9505 ;
9506
9507 changeable_control_properties:
9508 changeable_control_property
9509 | changeable_control_properties changeable_control_property
9510 ;
9511
9512 changeable_control_property:
9513 control_property _in_equal identifier
9514 | LAYOUT_DATA _in_equal identifier
9515 /* more to add here ... */
9516 ;
9517
9518 changeable_window_properties:
9519 changeable_window_property
9520 | changeable_window_properties changeable_window_property
9521 ;
9522
9523 changeable_window_property:
9524 TITLE _in_equal identifier
9525 | SIZE _in_equal identifier
9526 | LAYOUT_MANAGER _in_equal identifier
9527 /* more to add here ... */
9528 ;
9529
9530 eol:
9531 EOL
9532 | _end_of LINE
9533 ;
9534
9535 eos:
9536 EOS
9537 | _end_of SCREEN /* FIXME: this SCREEN is optional! */
9538 ;
9539
9540 _plus:
9541 /* empty */ { $$ = NULL; }
9542 | plus { $$ = $1; }
9543 ;
9544
9545 plus:
9546 plus_tokens { $$ = cb_int0; }
9547 ;
9548
9549 plus_tokens:
9550 PLUS | TOK_PLUS
9551 ;
9552
9553 minus:
9554 minus_tokens { $$ = cb_int1; }
9555 ;
9556
9557 minus_tokens:
9558 MINUS | TOK_MINUS
9559 ;
9560
9561 control_size:
9562 num_id_or_lit control_size_unit
9563 ;
9564
9565 control_size_unit:
9566 _cell { $$ = $0; }
9567 | PIXEL { $$ = cb_int1; }
9568 ;
9569
9570 _cell:
9571 /* empty */ { $$ = NULL; }
9572 | CELL { $$ = cb_int0; }
9573 ;
9574
9575 screen_line_number:
9576 _number _is _screen_line_plus_minus num_id_or_lit
9577 {
9578 if ($4) {
9579 current_field->screen_line = $4;
9580 }
9581 }
9582 ;
9583
9584 _screen_line_plus_minus:
9585 /* empty */
9586 | plus
9587 {
9588 current_field->screen_flag |= COB_SCREEN_LINE_PLUS;
9589 }
9590 | minus
9591 {
9592 current_field->screen_flag |= COB_SCREEN_LINE_MINUS;
9593 }
9594 ;
9595
9596 screen_col_number:
9597 _number _is _screen_col_plus_minus num_id_or_lit
9598 {
9599 if ($4) {
9600 current_field->screen_column = $4;
9601 }
9602 }
9603 ;
9604
9605 _screen_col_plus_minus:
9606 /* empty */
9607 {
9608 /* Nothing */
9609 }
9610 | plus
9611 {
9612 current_field->screen_flag |= COB_SCREEN_COLUMN_PLUS;
9613 }
9614 | minus
9615 {
9616 current_field->screen_flag |= COB_SCREEN_COLUMN_MINUS;
9617 }
9618 ;
9619
9620 screen_occurs_clause:
9621 OCCURS integer _times
9622 {
9623 CB_PENDING (_("OCCURS screen items"));
9624 check_repeated ("OCCURS", SYN_CLAUSE_23, &check_pic_duplicate);
9625 current_field->occurs_max = cb_get_int ($2);
9626 current_field->occurs_min = current_field->occurs_max;
9627 current_field->indexes++;
9628 current_field->flag_occurs = 1;
9629 }
9630 ;
9631
9632 screen_global_clause:
9633 _is GLOBAL
9634 {
9635 CB_PENDING (_("GLOBAL screen items"));
9636 }
9637 ;
9638
9639 /* PROCEDURE DIVISION */
9640
9641 _procedure_division:
9642 /* empty */
9643 {
9644 current_section = NULL;
9645 current_paragraph = NULL;
9646 check_pic_duplicate = 0;
9647 check_duplicate = 0;
9648 if (!current_program->entry_convention) {
9649 current_program->entry_convention = cb_int (CB_CONV_COBOL);
9650 }
9651 }
9652 | procedure_division
9653 ;
9654
9655 procedure_division:
9656 PROCEDURE DIVISION
9657 {
9658 current_section = NULL;
9659 current_paragraph = NULL;
9660 check_pic_duplicate = 0;
9661 check_duplicate = 0;
9662 cobc_in_procedure = 1U;
9663 cb_set_system_names ();
9664 backup_current_pos ();
9665 }
9666 _mnemonic_conv _conv_linkage _procedure_using_chaining _procedure_returning TOK_DOT
9667 {
9668 cb_tree call_conv = $4;
9669 if ($5) {
9670 call_conv = $5;
9671 if ($4) {
9672 /* note: $4 is likely to be a reference to SPECIAL-NAMES */
9673 cb_error_x ($5, _("%s and %s are mutually exclusive"),
9674 "CALL-CONVENTION", "WITH LINKAGE");
9675 }
9676 }
9677 if (call_conv) {
9678 if (current_program->entry_convention) {
9679 cb_warning (COBC_WARN_FILLER,
9680 _("overriding convention specified in ENTRY-CONVENTION"));
9681 }
9682 current_program->entry_convention = call_conv;
9683 } else if (!current_program->entry_convention) {
9684 current_program->entry_convention = cb_int (CB_CONV_COBOL);
9685 }
9686 header_check |= COBC_HD_PROCEDURE_DIVISION;
9687 }
9688 _procedure_declaratives
9689 {
9690 if (current_program->flag_main
9691 && !current_program->flag_chained && $6) {
9692 cb_error (_("executable program requested but PROCEDURE/ENTRY has USING clause"));
9693 }
9694 /* Main entry point */
9695 emit_entry (current_program->program_id, 0, $6, NULL);
9696 current_program->num_proc_params = cb_list_length ($6);
9697 if (current_program->source_name) {
9698 emit_entry (current_program->source_name, 1, $6, NULL);
9699 }
9700 }
9701 _procedure_list
9702 {
9703 if (current_paragraph) {
9704 if (current_paragraph->exit_label) {
9705 emit_statement (current_paragraph->exit_label);
9706 }
9707 emit_statement (cb_build_perform_exit (current_paragraph));
9708 }
9709 if (current_section) {
9710 if (current_section->exit_label) {
9711 emit_statement (current_section->exit_label);
9712 }
9713 emit_statement (cb_build_perform_exit (current_section));
9714 }
9715 }
9716 |
9717 {
9718 cb_tree label;
9719
9720 /* No PROCEDURE DIVISION header here */
9721 /* Only a statement is allowed as first element */
9722 /* Thereafter, sections/paragraphs may be used */
9723 check_pic_duplicate = 0;
9724 check_duplicate = 0;
9725 if (!current_program->entry_convention) {
9726 current_program->entry_convention = cb_int (CB_CONV_COBOL);
9727 }
9728 cobc_in_procedure = 1U;
9729 label = cb_build_reference ("MAIN SECTION");
9730 current_section = CB_LABEL (cb_build_label (label, NULL));
9731 current_section->flag_section = 1;
9732 current_section->flag_dummy_section = 1;
9733 current_section->flag_skip_label = !!skip_statements;
9734 current_section->flag_declaratives = !!in_declaratives;
9735 current_section->xref.skip = 1;
9736 emit_statement (CB_TREE (current_section));
9737 label = cb_build_reference ("MAIN PARAGRAPH");
9738 current_paragraph = CB_LABEL (cb_build_label (label, NULL));
9739 current_paragraph->flag_declaratives = !!in_declaratives;
9740 current_paragraph->flag_skip_label = !!skip_statements;
9741 current_paragraph->flag_dummy_paragraph = 1;
9742 current_paragraph->xref.skip = 1;
9743 emit_statement (CB_TREE (current_paragraph));
9744 cb_set_system_names ();
9745 }
9746 statements TOK_DOT _procedure_list
9747 ;
9748
9749 _procedure_using_chaining:
9750 /* empty */
9751 {
9752 $$ = NULL;
9753 }
9754 | USING
9755 {
9756 call_mode = CB_CALL_BY_REFERENCE;
9757 size_mode = CB_SIZE_4;
9758 }
9759 procedure_param_list
9760 {
9761 if (cb_list_length ($3) > MAX_CALL_FIELD_PARAMS) {
9762 cb_error (_("number of arguments exceeds maximum %d"),
9763 MAX_CALL_FIELD_PARAMS);
9764 }
9765 $$ = $3;
9766 }
9767 | CHAINING
9768 {
9769 call_mode = CB_CALL_BY_REFERENCE;
9770 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
9771 cb_error (_("CHAINING invalid in user FUNCTION"));
9772 } else {
9773 current_program->flag_chained = 1;
9774 }
9775 }
9776 procedure_param_list
9777 {
9778 if (cb_list_length ($3) > MAX_CALL_FIELD_PARAMS) {
9779 cb_error (_("number of arguments exceeds maximum %d"),
9780 MAX_CALL_FIELD_PARAMS);
9781 }
9782 $$ = $3;
9783 }
9784 ;
9785
9786 procedure_param_list:
9787 procedure_param { $$ = $1; }
9788 | procedure_param_list
9789 procedure_param { $$ = cb_list_append ($1, $2); }
9790 ;
9791
9792 procedure_param:
9793 _procedure_type _size_optional _procedure_optional WORD _acu_size
9794 {
9795 cb_tree x;
9796 struct cb_field *f;
9797
9798 x = cb_build_identifier ($4, 0);
9799 if ($3 == cb_int1 && CB_VALID_TREE (x) && cb_ref (x) != cb_error_node) {
9800 f = CB_FIELD (cb_ref (x));
9801 f->flag_is_pdiv_opt = 1;
9802 }
9803
9804 if (call_mode == CB_CALL_BY_VALUE
9805 && CB_REFERENCE_P ($4)
9806 && CB_FIELD (cb_ref ($4))->flag_any_length) {
9807 cb_error_x ($4, _("ANY LENGTH items may only be BY REFERENCE formal parameters"));
9808 }
9809
9810 $$ = CB_BUILD_PAIR (cb_int (call_mode), x);
9811 CB_SIZES ($$) = size_mode;
9812 }
9813 ;
9814
9815 _procedure_type:
9816 /* empty */
9817 | _by REFERENCE
9818 {
9819 call_mode = CB_CALL_BY_REFERENCE;
9820 }
9821 | _by VALUE
9822 {
9823 if (current_program->flag_chained) {
9824 cb_error (_("%s not allowed in CHAINED programs"), "BY VALUE");
9825 } else {
9826 CB_UNFINISHED (_("parameters passed BY VALUE"));
9827 call_mode = CB_CALL_BY_VALUE;
9828 }
9829 }
9830 ;
9831
9832 _size_optional:
9833 /* empty */
9834 | SIZE _is AUTO
9835 {
9836 if (call_mode != CB_CALL_BY_VALUE) {
9837 cb_error (_("SIZE only allowed for BY VALUE items"));
9838 } else {
9839 size_mode = CB_SIZE_AUTO;
9840 }
9841 }
9842 | SIZE _is DEFAULT
9843 {
9844 if (call_mode != CB_CALL_BY_VALUE) {
9845 cb_error (_("SIZE only allowed for BY VALUE items"));
9846 } else {
9847 size_mode = CB_SIZE_4;
9848 }
9849 }
9850 | UNSIGNED SIZE _is AUTO
9851 {
9852 if (call_mode != CB_CALL_BY_VALUE) {
9853 cb_error (_("SIZE only allowed for BY VALUE items"));
9854 } else {
9855 size_mode = CB_SIZE_AUTO | CB_SIZE_UNSIGNED;
9856 }
9857 }
9858 | UNSIGNED size_is_integer
9859 {
9860 if (size_mode) {
9861 size_mode |= CB_SIZE_UNSIGNED;
9862 }
9863 }
9864 | size_is_integer
9865 ;
9866
9867 size_is_integer:
9868 SIZE _is integer
9869 {
9870 unsigned char *s = CB_LITERAL ($3)->data;
9871 size_mode = 0;
9872
9873 if (call_mode != CB_CALL_BY_VALUE) {
9874 cb_error (_("SIZE only allowed for BY VALUE items"));
9875 } else if (CB_LITERAL ($3)->size != 1) {
9876 cb_error_x ($3, _("invalid value for SIZE"));
9877 } else {
9878 size_mode = 0;
9879 switch (*s) {
9880 case '1':
9881 size_mode = CB_SIZE_1;
9882 break;
9883 case '2':
9884 size_mode = CB_SIZE_2;
9885 break;
9886 case '4':
9887 size_mode = CB_SIZE_4;
9888 break;
9889 case '8':
9890 size_mode = CB_SIZE_8;
9891 break;
9892 default:
9893 cb_error_x ($3, _("invalid value for SIZE"));
9894 break;
9895 }
9896 }
9897 }
9898 ;
9899
9900 /* The [MEMORY] SIZE phrase is used when the parameter in the
9901 USING phrase is a memory address (pointer to memory)
9902 and you need to specify the size of the piece of memory
9903 that is located at that address. */
9904 _acu_size:
9905 /* empty */
9906 | _with MEMORY SIZE _is positive_id_or_lit
9907 {
9908 CB_PENDING_X ($4, _("MEMORY SIZE phrase in CALL statement"));
9909 }
9910 ;
9911
9912 _procedure_optional:
9913 /* empty */
9914 {
9915 $$ = cb_int0;
9916 }
9917 | OPTIONAL
9918 {
9919 if (call_mode != CB_CALL_BY_REFERENCE) {
9920 cb_error (_("OPTIONAL only allowed for BY REFERENCE items"));
9921 $$ = cb_int0;
9922 } else {
9923 $$ = cb_int1;
9924 }
9925 }
9926 ;
9927
9928 _procedure_returning:
9929 /* empty */
9930 {
9931 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
9932 cb_error (_("RETURNING clause is required for a FUNCTION"));
9933 }
9934 }
9935 | RETURNING OMITTED
9936 {
9937 if (current_program->flag_main) {
9938 cb_error (_("RETURNING clause cannot be OMITTED for main program"));
9939 }
9940 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
9941 cb_error (_("RETURNING clause cannot be OMITTED for a FUNCTION"));
9942 }
9943 current_program->flag_void = 1;
9944 }
9945 | RETURNING WORD
9946 {
9947 struct cb_field *f;
9948
9949 if (cb_ref ($2) != cb_error_node) {
9950 f = CB_FIELD_PTR ($2);
9951 /* standard rule: returning item is allocated in the
9952 activating runtime element */
9953 if (f->storage != CB_STORAGE_LINKAGE) {
9954 cb_error (_("RETURNING item is not defined in LINKAGE SECTION"));
9955 } else if (f->level != 1 && f->level != 77) {
9956 cb_error (_("RETURNING item must have level 01"));
9957 } else if (f->flag_occurs) {
9958 cb_error (_("RETURNING item should not have OCCURS"));
9959 } else {
9960 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
9961 if (f->flag_any_length) {
9962 cb_error (_("function RETURNING item may not be ANY LENGTH"));
9963 }
9964 f->flag_is_returning = 1;
9965 }
9966 #if 0 /* doesn't work for programs, will be fixed with allocating in the source-unit */
9967 current_program->returning = $2;
9968 #else
9969 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
9970 current_program->returning = $2;
9971 } else {
9972 CB_PENDING ("program RETURNING");
9973 }
9974 #endif
9975 }
9976 }
9977 }
9978 ;
9979
9980 _procedure_declaratives:
9981 | DECLARATIVES TOK_DOT
9982 {
9983 in_declaratives = 1;
9984 emit_statement (cb_build_comment ("DECLARATIVES"));
9985 }
9986 _procedure_list
9987 END DECLARATIVES TOK_DOT
9988 {
9989 if (needs_field_debug) {
9990 start_debug = 1;
9991 }
9992 in_declaratives = 0;
9993 in_debugging = 0;
9994 if (current_paragraph) {
9995 if (current_paragraph->exit_label) {
9996 emit_statement (current_paragraph->exit_label);
9997 }
9998 emit_statement (cb_build_perform_exit (current_paragraph));
9999 current_paragraph = NULL;
10000 }
10001 if (current_section) {
10002 if (current_section->exit_label) {
10003 emit_statement (current_section->exit_label);
10004 }
10005 current_section->flag_fatal_check = 1;
10006 emit_statement (cb_build_perform_exit (current_section));
10007 current_section = NULL;
10008 }
10009 skip_statements = 0;
10010 emit_statement (cb_build_comment ("END DECLARATIVES"));
10011 check_unreached = 0;
10012 }
10013 ;
10014
10015
10016 /* Procedure list */
10017
10018 _procedure_list:
10019 | _procedure_list procedure
10020 ;
10021
10022 procedure:
10023 section_header
10024 | paragraph_header
10025 | statements TOK_DOT
10026 {
10027 if (next_label_list) {
10028 cb_tree plabel;
10029 char name[32];
10030
10031 snprintf (name, sizeof(name), "L$%d", next_label_id);
10032 plabel = cb_build_label (cb_build_reference (name), NULL);
10033 CB_LABEL (plabel)->flag_next_sentence = 1;
10034 emit_statement (plabel);
10035 current_program->label_list =
10036 cb_list_append (current_program->label_list, next_label_list);
10037 next_label_list = NULL;
10038 next_label_id++;
10039 }
10040 /* check_unreached = 0; */
10041 cb_end_statement();
10042 }
10043 | invalid_statement %prec SHIFT_PREFER
10044 | TOK_DOT
10045 {
10046 /* check_unreached = 0; */
10047 cb_end_statement();
10048 }
10049 ;
10050
10051
10052 /* Section/Paragraph */
10053
10054 section_header:
10055 WORD SECTION
10056 {
10057 non_const_word = 0;
10058 check_unreached = 0;
10059 if (cb_build_section_name ($1, 0) == cb_error_node) {
10060 YYERROR;
10061 }
10062
10063 /* Exit the last paragraph/section */
10064 if (current_paragraph) {
10065 if (current_paragraph->exit_label) {
10066 emit_statement (current_paragraph->exit_label);
10067 }
10068 emit_statement (cb_build_perform_exit (current_paragraph));
10069 }
10070 if (current_section) {
10071 if (current_section->exit_label) {
10072 emit_statement (current_section->exit_label);
10073 }
10074 emit_statement (cb_build_perform_exit (current_section));
10075 }
10076 if (current_program->flag_debugging && !in_debugging) {
10077 if (current_paragraph || current_section) {
10078 emit_statement (cb_build_comment (
10079 "DEBUGGING - Fall through"));
10080 emit_statement (cb_build_debug (cb_debug_contents,
10081 "FALL THROUGH", NULL));
10082 }
10083 }
10084
10085 /* Begin a new section */
10086 current_section = CB_LABEL (cb_build_label ($1, NULL));
10087 current_section->flag_section = 1;
10088 /* Careful here, one negation */
10089 current_section->flag_real_label = !in_debugging;
10090 current_section->flag_declaratives = !!in_declaratives;
10091 current_section->flag_skip_label = !!skip_statements;
10092 current_paragraph = NULL;
10093 }
10094 _segment TOK_DOT
10095 _use_statement
10096 {
10097 emit_statement (CB_TREE (current_section));
10098 }
10099 ;
10100
10101 _use_statement:
10102 | use_statement TOK_DOT
10103 ;
10104
10105 paragraph_header:
10106 WORD TOK_DOT
10107 {
10108 cb_tree label;
10109
10110 non_const_word = 0;
10111 check_unreached = 0;
10112 if (cb_build_section_name ($1, 1) == cb_error_node) {
10113 YYERROR;
10114 }
10115
10116 /* Exit the last paragraph */
10117 if (current_paragraph) {
10118 if (current_paragraph->exit_label) {
10119 emit_statement (current_paragraph->exit_label);
10120 }
10121 emit_statement (cb_build_perform_exit (current_paragraph));
10122 if (current_program->flag_debugging && !in_debugging) {
10123 emit_statement (cb_build_comment (
10124 "DEBUGGING - Fall through"));
10125 emit_statement (cb_build_debug (cb_debug_contents,
10126 "FALL THROUGH", NULL));
10127 }
10128 }
10129
10130 /* Begin a new paragraph */
10131 if (!current_section) {
10132 label = cb_build_reference ("MAIN SECTION");
10133 current_section = CB_LABEL (cb_build_label (label, NULL));
10134 current_section->flag_section = 1;
10135 current_section->flag_dummy_section = 1;
10136 current_section->flag_declaratives = !!in_declaratives;
10137 current_section->flag_skip_label = !!skip_statements;
10138 current_section->xref.skip = 1;
10139 emit_statement (CB_TREE (current_section));
10140 }
10141 current_paragraph = CB_LABEL (cb_build_label ($1, current_section));
10142 current_paragraph->flag_declaratives = !!in_declaratives;
10143 current_paragraph->flag_skip_label = !!skip_statements;
10144 current_paragraph->flag_real_label = !in_debugging;
10145 current_paragraph->segment = current_section->segment;
10146 emit_statement (CB_TREE (current_paragraph));
10147 }
10148 ;
10149
10150 invalid_statement:
10151 WORD
10152 {
10153 non_const_word = 0;
10154 check_unreached = 0;
10155 if (cb_build_section_name ($1, 0) != cb_error_node) {
10156 if (is_reserved_word (CB_NAME ($1))) {
10157 cb_error_x ($1, _("'%s' is not a statement"), CB_NAME ($1));
10158 } else if (is_default_reserved_word (CB_NAME ($1))) {
10159 cb_error_x ($1, _("unknown statement '%s'; it may exist in another dialect"),
10160 CB_NAME ($1));
10161 } else {
10162 cb_error_x ($1, _("unknown statement '%s'"), CB_NAME ($1));
10163 }
10164 }
10165 YYERROR;
10166 }
10167 ;
10168
10169 _segment:
10170 /* empty */
10171 {
10172 $$ = NULL;
10173 }
10174 | integer
10175 {
10176 $$ = NULL;
10177 if (cb_verify (cb_section_segments, _("section segments"))) {
10178 int segnum = cb_get_int ($1);
10179 if (segnum > 99) {
10180 cb_error (_("SECTION segment-number must be less than or equal to 99"));
10181 } else {
10182 if (in_declaratives && segnum > 49) {
10183 cb_error (_("SECTION segment-number in DECLARATIVES must be less than 50"));
10184 }
10185 if (!in_declaratives) {
10186 current_program->flag_segments = 1;
10187 current_section->segment = segnum;
10188 } else {
10189 /* Simon: old version did not allow segments in declaratives at all
10190 ToDo: check codegen for possible missing parts */
10191 CB_PENDING (_("SECTION segment within DECLARATIVES"));
10192 }
10193 }
10194 }
10195 }
10196 ;
10197
10198
10199 /* Statements */
10200
10201 statement_list:
10202 %prec SHIFT_PREFER
10203 {
10204 /* push exec_list on the stack ($1), then unset */
10205 $$ = current_program->exec_list;
10206 current_program->exec_list = NULL;
10207 check_unreached = 0;
10208 }
10209 {
10210 /* push statement on the stack ($2), then unset */
10211 $$ = CB_TREE (current_statement);
10212 current_statement = NULL;
10213 }
10214 statements
10215 {
10216 /* reorder exec_list which was filled in "statements" and push to stack ($$),
10217 then backup exec_list and statement from the stack ($1, $2) */
10218 $$ = cb_list_reverse (current_program->exec_list);
10219 current_program->exec_list = $1;
10220 current_statement = CB_STATEMENT ($2);
10221 }
10222 ;
10223
10224 statements:
10225 {
10226 cb_tree label;
10227
10228 if (!current_section) {
10229 label = cb_build_reference ("MAIN SECTION");
10230 current_section = CB_LABEL (cb_build_label (label, NULL));
10231 current_section->flag_section = 1;
10232 current_section->flag_dummy_section = 1;
10233 current_section->flag_skip_label = !!skip_statements;
10234 current_section->flag_declaratives = !!in_declaratives;
10235 current_section->xref.skip = 1;
10236 emit_statement (CB_TREE (current_section));
10237 }
10238 if (!current_paragraph) {
10239 label = cb_build_reference ("MAIN PARAGRAPH");
10240 current_paragraph = CB_LABEL (cb_build_label (label, NULL));
10241 CB_TREE (current_paragraph)->source_file
10242 = CB_TREE (current_section)->source_file;
10243 CB_TREE (current_paragraph)->source_line
10244 = CB_TREE (current_section)->source_line;
10245 current_paragraph->flag_declaratives = !!in_declaratives;
10246 current_paragraph->flag_skip_label = !!skip_statements;
10247 current_paragraph->flag_dummy_paragraph = 1;
10248 current_paragraph->xref.skip = 1;
10249 emit_statement (CB_TREE (current_paragraph));
10250 }
10251 if (check_headers_present (COBC_HD_PROCEDURE_DIVISION, 0, 0, 0) == 1) {
10252 if (current_program->prog_type == COB_MODULE_TYPE_PROGRAM) {
10253 backup_current_pos ();
10254 emit_entry (current_program->program_id, 0, NULL, NULL);
10255 }
10256 }
10257
10258 cobc_apply_turn_directives ();
10259 }
10260 statement
10261 {
10262 cobc_cs_check = 0;
10263 cobc_apply_turn_directives ();
10264 }
10265 | statements statement
10266 {
10267 cobc_cs_check = 0;
10268 cobc_apply_turn_directives ();
10269 }
10270 ;
10271
10272 statement:
10273 accept_statement
10274 | add_statement
10275 | allocate_statement
10276 | alter_statement
10277 | call_statement
10278 | cancel_statement
10279 | close_statement
10280 | commit_statement
10281 | compute_statement
10282 | continue_statement
10283 | delete_statement
10284 | destroy_statement
10285 | disable_statement
10286 | display_statement
10287 | divide_statement
10288 | enable_statement
10289 | entry_statement
10290 | evaluate_statement
10291 | exhibit_statement
10292 | exit_statement
10293 | free_statement
10294 | generate_statement
10295 | goto_statement
10296 | goback_statement
10297 | if_statement
10298 | initialize_statement
10299 | initiate_statement
10300 | inquire_statement
10301 | inspect_statement
10302 /* | TODO: invoke_statement */
10303 | json_generate_statement
10304 | json_parse_statement
10305 | merge_statement
10306 | modify_statement
10307 | move_statement
10308 | multiply_statement
10309 | open_statement
10310 | perform_statement
10311 | purge_statement
10312 | raise_statement
10313 | read_statement
10314 | ready_statement
10315 | receive_statement
10316 | release_statement
10317 | reset_statement
10318 /* | TODO: resume_statement */
10319 | return_statement
10320 | rewrite_statement
10321 | rollback_statement
10322 | search_statement
10323 | send_statement
10324 | set_statement
10325 | sort_statement
10326 | start_statement
10327 | stop_statement
10328 | string_statement
10329 | subtract_statement
10330 | suppress_statement
10331 | terminate_statement
10332 | transform_statement
10333 | unlock_statement
10334 | unstring_statement
10335 | validate_statement
10336 | write_statement
10337 | xml_generate_statement
10338 | xml_parse_statement
10339 | %prec SHIFT_PREFER
10340 NEXT SENTENCE
10341 {
10342 if (cb_verify (cb_next_sentence_phrase, "NEXT SENTENCE")) {
10343 cb_tree label;
10344 char name[32];
10345
10346 begin_statement ("NEXT SENTENCE", 0);
10347 sprintf (name, "L$%d", next_label_id);
10348 label = cb_build_reference (name);
10349 next_label_list = cb_list_add (next_label_list, label);
10350 emit_statement (cb_build_goto (label, NULL));
10351 }
10352 check_unreached = 0;
10353 }
10354 | error error_stmt_recover
10355 {
10356 yyerrok;
10357 cobc_cs_check = 0;
10358 }
10359 ;
10360
10361
10362 /* ACCEPT statement */
10363
10364 accept_statement:
10365 ACCEPT
10366 {
10367 begin_statement ("ACCEPT", TERM_ACCEPT);
10368 cobc_cs_check = CB_CS_ACCEPT;
10369 }
10370 accept_body
10371 _end_accept
10372 ;
10373
10374 accept_body:
10375 accp_identifier
10376 {
10377 check_duplicate = 0;
10378 check_line_col_duplicate = 0;
10379 line_column = NULL;
10380 }
10381 _accept_clauses _accept_exception_phrases
10382 {
10383 /* Check for invalid use of screen clauses */
10384 if (current_statement->attr_ptr
10385 || (!is_screen_field ($1) && line_column)) {
10386 cb_verify_x ($1, cb_accept_display_extensions,
10387 _("non-standard ACCEPT"));
10388 }
10389
10390 if (cb_accept_update && !has_dispattr (COB_SCREEN_NO_UPDATE)) {
10391 set_dispattr (COB_SCREEN_UPDATE);
10392 }
10393 if (cb_accept_auto && !has_dispattr (COB_SCREEN_TAB)) {
10394 set_dispattr (COB_SCREEN_AUTO);
10395 }
10396 if ($1 == cb_null && current_statement->attr_ptr) {
10397 if (current_statement->attr_ptr->prompt) {
10398 emit_conflicting_clause_message ("ACCEPT OMITTED",
10399 _("PROMPT clause"));
10400 }
10401 if (current_statement->attr_ptr->size_is) {
10402 emit_conflicting_clause_message ("ACCEPT OMITTED",
10403 _("SIZE IS clause"));
10404 }
10405 }
10406 cobc_cs_check = 0;
10407 cb_emit_accept ($1, line_column, current_statement->attr_ptr);
10408 }
10409 | identifier FROM SCREEN
10410 {
10411 check_duplicate = 0;
10412 check_line_col_duplicate = 0;
10413 line_column = NULL;
10414 }
10415 accept_from_screen_clauses
10416 {
10417 cobc_cs_check = 0;
10418 CB_PENDING ("ACCEPT FROM SCREEN");
10419 }
10420 | identifier FROM lines_or_number
10421 {
10422 cb_emit_accept_line_or_col ($1, 0);
10423 }
10424 | identifier FROM columns_or_cols
10425 {
10426 cb_emit_accept_line_or_col ($1, 1);
10427 }
10428 | identifier FROM TERMINAL_INFO
10429 {
10430 /* information about terminal and its capabilities
10431 cb_emit_accept_terminal_info ($1); */
10432 CB_PENDING ("ACCEPT FROM TERMINAL INFO");
10433 }
10434 | identifier FROM SYSTEM_INFO
10435 {
10436 /* information about OS and runtime features
10437 cb_emit_accept_system_info ($1); */
10438 CB_PENDING ("ACCEPT FROM SYSTEM INFO");
10439 }
10440 | identifier FROM DATE YYYYMMDD
10441 {
10442 cobc_cs_check = 0;
10443 cb_emit_accept_date_yyyymmdd ($1);
10444 }
10445 | identifier FROM DATE
10446 {
10447 cobc_cs_check = 0;
10448 cb_emit_accept_date ($1);
10449 }
10450 | identifier FROM DAY YYYYDDD
10451 {
10452 cobc_cs_check = 0;
10453 cb_emit_accept_day_yyyyddd ($1);
10454 }
10455 | identifier FROM DAY
10456 {
10457 cobc_cs_check = 0;
10458 cb_emit_accept_day ($1);
10459 }
10460 | identifier FROM DAY_OF_WEEK
10461 {
10462 cb_emit_accept_day_of_week ($1);
10463 }
10464 /* note: GnuCOBOL uses screenio.cpy 9(4) identifier,
10465 MicroFocus/ACUCOBOL 99 */
10466 | identifier FROM ESCAPE _key
10467 {
10468 cb_emit_accept_escape_key ($1);
10469 }
10470 /* note: GnuCOBOL uses ISO X(4) identifier,
10471 MicroFocus 9(3) */
10472 | identifier FROM EXCEPTION STATUS
10473 {
10474 cb_emit_accept_exception_status ($1);
10475 }
10476 | identifier FROM INPUT STATUS
10477 {
10478 /* check is data from keyboard available? "1", else "0"
10479 cb_emit_accept_input_status ($1); */
10480 CB_PENDING ("ACCEPT FROM INPUT STATUS");
10481 }
10482 | identifier FROM TIME
10483 {
10484 cb_emit_accept_time ($1);
10485 }
10486 | identifier FROM USER NAME
10487 {
10488 cobc_cs_check = 0;
10489 cb_emit_accept_user_name ($1);
10490 }
10491 | identifier FROM COMMAND_LINE
10492 {
10493 cb_emit_accept_command_line ($1);
10494 }
10495 | identifier FROM ENVIRONMENT_VALUE _accept_exception_phrases
10496 {
10497 cb_emit_accept_environment ($1);
10498 }
10499 | identifier FROM ENVIRONMENT simple_display_value _accept_exception_phrases
10500 {
10501 cb_emit_get_environment ($4, $1);
10502 }
10503 | identifier FROM ARGUMENT_NUMBER
10504 {
10505 cb_emit_accept_arg_number ($1);
10506 }
10507 | identifier FROM ARGUMENT_VALUE _accept_exception_phrases
10508 {
10509 cb_emit_accept_arg_value ($1);
10510 }
10511 | identifier FROM mnemonic_name
10512 {
10513 cb_emit_accept_mnemonic ($1, $3);
10514 }
10515 | identifier FROM WORD
10516 {
10517 cb_emit_accept_name ($1, $3);
10518 }
10519 | field_with_pos_specifier _accept_clauses
10520 {
10521 cb_verify_x ($1, cb_accept_display_extensions,
10522 _("non-standard ACCEPT"));
10523
10524 if (cb_accept_update && !has_dispattr (COB_SCREEN_NO_UPDATE)) {
10525 set_dispattr (COB_SCREEN_UPDATE);
10526 }
10527 if (cb_accept_auto && !has_dispattr (COB_SCREEN_TAB)) {
10528 set_dispattr (COB_SCREEN_AUTO);
10529 }
10530 cobc_cs_check = 0;
10531 cb_emit_accept ($1, line_column, current_statement->attr_ptr);
10532 }
10533 | cd_name _message COUNT
10534 {
10535 CB_PENDING ("ACCEPT MESSAGE COUNT");
10536 }
10537 ;
10538
10539 accp_identifier:
10540 identifier
10541 | OMITTED
10542 {
10543 $$ = cb_null;
10544 }
10545 ;
10546
10547 field_with_pos_specifier:
10548 {
10549 check_duplicate = 0;
10550 check_line_col_duplicate = 0;
10551 line_column = NULL;
10552 }
10553 pos_specifier identifier
10554 {
10555 $$ = $3;
10556 }
10557 ;
10558
10559 _pos_specifier:
10560 /* empty */ | pos_specifier
10561 ;
10562
10563 pos_specifier:
10564 TOK_OPEN_PAREN pos_specifier_value COMMA_DELIM pos_specifier_value TOK_CLOSE_PAREN
10565 {
10566 line_column = CB_BUILD_PAIR ($2, $4);
10567 }
10568 | TOK_OPEN_PAREN pos_specifier_value COMMA_DELIM TOK_CLOSE_PAREN
10569 {
10570 line_column = CB_BUILD_PAIR ($2, cb_int0);
10571 }
10572 | TOK_OPEN_PAREN COMMA_DELIM pos_specifier_value TOK_CLOSE_PAREN
10573 {
10574 line_column = CB_BUILD_PAIR (cb_int0, $3);
10575 }
10576 ;
10577
10578 pos_specifier_value:
10579 identifier_or_numeric_literal /* note: handles special register LIN/COL, too */
10580 {
10581 $$ = $1;
10582 }
10583 | identifier_or_numeric_literal TOK_PLUS numeric_literal
10584 {
10585 $$ = cb_build_binary_op ($1, '+', $3);
10586 }
10587 | identifier_or_numeric_literal TOK_MINUS numeric_literal
10588 {
10589 $$ = cb_build_binary_op ($1, '-', $3);
10590 }
10591 ;
10592
10593 identifier_or_numeric_literal:
10594 identifier
10595 | numeric_literal
10596 ;
10597
10598
10599 _accept_clauses:
10600 /* empty */
10601 | accept_clauses
10602 ;
10603
10604 accept_clauses:
10605 accept_clause
10606 | accept_clauses accept_clause
10607 ;
10608
10609 accept_clause:
10610 at_line_column
10611 | FROM_CRT
10612 {
10613 check_repeated ("FROM CRT", SYN_CLAUSE_2, &check_duplicate);
10614 }
10615 | mode_is_block
10616 {
10617 check_repeated ("MODE IS BLOCK", SYN_CLAUSE_3, &check_duplicate);
10618 }
10619 | _with accp_attr
10620 | _before TIME positive_id_or_lit
10621 {
10622 check_repeated (_("TIME-OUT or BEFORE TIME clauses"), SYN_CLAUSE_4,
10623 &check_duplicate);
10624 set_attribs (NULL, NULL, NULL, $3, NULL, NULL, 0);
10625 }
10626 ;
10627
10628 accept_from_screen_clauses:
10629 accept_from_screen_clause
10630 | accept_from_screen_clauses accept_from_screen_clause
10631 ;
10632
10633 accept_from_screen_clause:
10634 /* FIXME: could be optional FROM instead of optional AT */
10635 at_line_column
10636 | SIZE _is pos_num_id_or_lit_or_zero /* ignored, as ACCEPT FROM is pending */
10637 ;
10638
10639 lines_or_number:
10640 LINES
10641 | LINE NUMBER
10642 ;
10643
10644 at_line_column:
10645 _at line_number
10646 {
10647 set_attr_with_conflict ("LINE", SYN_CLAUSE_1,
10648 _("AT screen-location"), SYN_CLAUSE_3, 1,
10649 &check_line_col_duplicate);
10650
10651 if ((CB_LITERAL_P ($2) && cb_get_int ($2) == 0) || $2 == cb_zero) {
10652 cb_verify (cb_accept_display_extensions, "LINE 0");
10653 }
10654
10655 if (!line_column) {
10656 line_column = CB_BUILD_PAIR ($2, cb_int0);
10657 } else {
10658 CB_PAIR_X (line_column) = $2;
10659 }
10660 }
10661 | _at column_number
10662 {
10663 set_attr_with_conflict ("COLUMN", SYN_CLAUSE_2,
10664 _("AT screen-location"), SYN_CLAUSE_3, 1,
10665 &check_line_col_duplicate);
10666
10667 if ((CB_LITERAL_P ($2) && cb_get_int ($2) == 0) || $2 == cb_zero) {
10668 cb_verify (cb_accept_display_extensions, "COLUMN 0");
10669 }
10670
10671 if (!line_column) {
10672 line_column = CB_BUILD_PAIR (cb_int0, $2);
10673 } else {
10674 CB_PAIR_Y (line_column) = $2;
10675 }
10676 }
10677 | AT num_id_or_lit
10678 {
10679 set_attr_with_conflict (_("AT screen-location"), SYN_CLAUSE_3,
10680 _("LINE or COLUMN"), SYN_CLAUSE_1 | SYN_CLAUSE_2,
10681 1, &check_line_col_duplicate);
10682
10683 cb_verify (cb_accept_display_extensions, "AT clause");
10684
10685 line_column = $2;
10686 }
10687 ;
10688
10689 line_number:
10690 LINE _number num_id_or_lit
10691 {
10692 /* FIXME: arithmetic expression should be possible, too, only numeric literals! */
10693 $$ = $3;
10694 }
10695 ;
10696
10697 column_number:
10698 column_or_col_or_position_or_pos _number num_id_or_lit
10699 {
10700 /* FIXME: arithmetic expression should be possible, too, only numeric literals! */
10701 $$ = $3;
10702 }
10703 ;
10704
10705 mode_is_block:
10706 MODE _is BLOCK
10707 {
10708 cobc_cs_check = 0;
10709 }
10710 ;
10711
10712 accp_attr:
10713 AUTO
10714 {
10715 check_repeated ("AUTO", SYN_CLAUSE_5, &check_duplicate);
10716 set_dispattr_with_conflict ("AUTO", COB_SCREEN_AUTO,
10717 "TAB", COB_SCREEN_TAB);
10718 }
10719 | TAB
10720 {
10721 check_repeated ("TAB", SYN_CLAUSE_6, &check_duplicate);
10722 set_dispattr_with_conflict ("TAB", COB_SCREEN_TAB,
10723 "AUTO", COB_SCREEN_AUTO);
10724 }
10725 | BELL
10726 {
10727 check_repeated ("BELL", SYN_CLAUSE_7, &check_duplicate);
10728 set_dispattr (COB_SCREEN_BELL);
10729 }
10730 | NO BELL
10731 {
10732 check_repeated ("BELL", SYN_CLAUSE_7, &check_duplicate);
10733 /* FIXME: do we need a COB_NO_SCREEN_BELL here?
10734 set_dispattr (COB_SCREEN_BELL); */
10735 }
10736 | BLINK
10737 {
10738 check_repeated ("BLINK", SYN_CLAUSE_8, &check_duplicate);
10739 set_dispattr (COB_SCREEN_BLINK);
10740 }
10741 | CONVERSION
10742 {
10743 check_repeated ("CONVERSION", SYN_CLAUSE_9, &check_duplicate);
10744 CB_PENDING ("ACCEPT CONVERSION");
10745 }
10746 | CURSOR _is positive_id_or_lit
10747 {
10748 /* FIXME: arithmetic expression should be possible, too! */
10749 if (current_program->cursor_pos) {
10750 emit_duplicate_clause_message ("CURSOR");
10751 } else {
10752 /* TODO: actually reasonable and easy extension: an
10753 *offset within the field* [auto-correct to 1/max]
10754 (when variable also stored back on return)
10755 */
10756 CB_PENDING ("ACCEPT ... WITH CURSOR");
10757 }
10758 }
10759 | FULL
10760 {
10761 check_repeated ("FULL", SYN_CLAUSE_10, &check_duplicate);
10762 set_dispattr (COB_SCREEN_FULL);
10763 }
10764 | LEFTLINE
10765 {
10766 check_repeated ("LEFTLINE", SYN_CLAUSE_12, &check_duplicate);
10767 set_dispattr (COB_SCREEN_LEFTLINE);
10768 }
10769 | LOWER
10770 {
10771 check_repeated ("LOWER", SYN_CLAUSE_13, &check_duplicate);
10772 set_dispattr_with_conflict ("LOWER", COB_SCREEN_LOWER,
10773 "UPPER", COB_SCREEN_UPPER);
10774 }
10775 | HIGHLIGHT
10776 {
10777 check_repeated ("HIGHLIGHT", SYN_CLAUSE_11, &check_duplicate);
10778 set_dispattr_with_conflict ("HIGHLIGHT", COB_SCREEN_HIGHLIGHT,
10779 "LOWLIGHT", COB_SCREEN_LOWLIGHT);
10780 }
10781 | LOWLIGHT
10782 {
10783 check_repeated ("LOWLIGHT", SYN_CLAUSE_14, &check_duplicate);
10784 set_dispattr_with_conflict ("LOWLIGHT", COB_SCREEN_LOWLIGHT,
10785 "HIGHLIGHT", COB_SCREEN_HIGHLIGHT);
10786 }
10787 | SAME /* ACU (?) extension to use the video attributes
10788 currently present at the field's screen location. */
10789 {
10790 CB_PENDING ("SAME phrase");
10791 /* may not be specified along with the UNDERLINED, BLINK, REVERSED,
10792 HIGH, LOW, STANDARD, COLOR, FOREGROUND-COLOR, or BACKGROUND-COLOR phrases */
10793 }
10794 | STANDARD /* ACU extension to reset a group HIGH/LOW */
10795 {
10796 CB_PENDING ("STANDARD intensity");
10797 }
10798 | BACKGROUND_HIGH
10799 {
10800 CB_PENDING ("BACKGROUND intensity");
10801 }
10802 | BACKGROUND_LOW
10803 {
10804 CB_PENDING ("BACKGROUND intensity");
10805 }
10806 | BACKGROUND_STANDARD
10807 {
10808 CB_PENDING ("BACKGROUND intensity");
10809 }
10810 | no_echo
10811 {
10812 if (cb_no_echo_means_secure) {
10813 check_repeated ("SECURE", SYN_CLAUSE_20, &check_duplicate);
10814 set_dispattr (COB_SCREEN_SECURE);
10815 } else {
10816 check_repeated ("NO-ECHO", SYN_CLAUSE_15, &check_duplicate);
10817 set_dispattr_with_conflict ("NO-ECHO", COB_SCREEN_NO_ECHO,
10818 "SECURE", COB_SCREEN_SECURE);
10819 }
10820 }
10821 | OVERLINE
10822 {
10823 check_repeated ("OVERLINE", SYN_CLAUSE_16, &check_duplicate);
10824 set_dispattr (COB_SCREEN_OVERLINE);
10825 }
10826 | PROMPT _character _is id_or_lit
10827 {
10828 /* Note: CHARACTER optional in ACUCOBOL, required by others */
10829 check_repeated ("PROMPT", SYN_CLAUSE_17, &check_duplicate);
10830 set_attribs (NULL, NULL, NULL, NULL, $4, NULL, COB_SCREEN_PROMPT);
10831 }
10832 | PROMPT
10833 {
10834 check_repeated ("PROMPT", SYN_CLAUSE_17, &check_duplicate);
10835 set_dispattr (COB_SCREEN_PROMPT);
10836 }
10837 | REQUIRED
10838 {
10839 check_repeated ("REQUIRED", SYN_CLAUSE_18, &check_duplicate);
10840 set_dispattr (COB_SCREEN_REQUIRED);
10841 }
10842 | reverse_video
10843 {
10844 check_repeated ("REVERSE-VIDEO", SYN_CLAUSE_19, &check_duplicate);
10845 set_dispattr (COB_SCREEN_REVERSE);
10846 }
10847 | SECURE
10848 {
10849 check_repeated ("SECURE", SYN_CLAUSE_20, &check_duplicate);
10850 set_dispattr_with_conflict ("SECURE", COB_SCREEN_SECURE,
10851 "NO-ECHO", COB_SCREEN_NO_ECHO);
10852 }
10853 | _protected SIZE _is pos_num_id_or_lit_or_zero
10854 {
10855 /* FIXME: arithmetic expression should be possible, too! */
10856 check_repeated ("SIZE", SYN_CLAUSE_21, &check_duplicate);
10857 set_attribs (NULL, NULL, NULL, NULL, NULL, $4, 0);
10858 }
10859 | UNDERLINE
10860 {
10861 check_repeated ("UNDERLINE", SYN_CLAUSE_22, &check_duplicate);
10862 set_dispattr (COB_SCREEN_UNDERLINE);
10863 }
10864 | NO update_default
10865 {
10866 check_repeated ("NO UPDATE", SYN_CLAUSE_23, &check_duplicate);
10867 set_dispattr_with_conflict ("NO UPDATE", COB_SCREEN_NO_UPDATE,
10868 "UPDATE", COB_SCREEN_UPDATE);
10869 }
10870 | update_default
10871 {
10872 check_repeated ("UPDATE", SYN_CLAUSE_24, &check_duplicate);
10873 set_dispattr_with_conflict ("UPDATE", COB_SCREEN_UPDATE,
10874 "NO UPDATE", COB_SCREEN_NO_UPDATE);
10875 }
10876 | UPPER
10877 {
10878 check_repeated ("UPPER", SYN_CLAUSE_25, &check_duplicate);
10879 set_dispattr_with_conflict ("UPPER", COB_SCREEN_UPPER,
10880 "LOWER", COB_SCREEN_LOWER);
10881 }
10882 | COLOR _is num_id_or_lit
10883 {
10884 /* FIXME: arithmetic expression should be possible, too! */
10885 check_repeated ("FOREGROUND-COLOR", SYN_CLAUSE_26, &check_duplicate);
10886 check_repeated ("BACKGROUND-COLOR", SYN_CLAUSE_27, &check_duplicate);
10887 CB_PENDING ("COLOR");
10888 }
10889 | FOREGROUND_COLOR _is num_id_or_lit
10890 {
10891 check_repeated ("FOREGROUND-COLOR", SYN_CLAUSE_26, &check_duplicate);
10892 set_attribs ($3, NULL, NULL, NULL, NULL, NULL, 0);
10893 }
10894 | BACKGROUND_COLOR _is num_id_or_lit
10895 {
10896 check_repeated ("BACKGROUND-COLOR", SYN_CLAUSE_27, &check_duplicate);
10897 set_attribs (NULL, $3, NULL, NULL, NULL, NULL, 0);
10898 }
10899 | SCROLL _up _scroll_lines
10900 {
10901 check_repeated ("SCROLL UP", SYN_CLAUSE_28, &check_duplicate);
10902 set_attribs_with_conflict (NULL, NULL, $3, NULL, NULL, NULL,
10903 "SCROLL UP", COB_SCREEN_SCROLL_UP,
10904 "SCROLL DOWN", COB_SCREEN_SCROLL_DOWN);
10905 }
10906 | SCROLL DOWN _scroll_lines
10907 {
10908 check_repeated ("SCROLL DOWN", SYN_CLAUSE_19, &check_duplicate);
10909 set_attribs_with_conflict (NULL, NULL, $3, NULL, NULL, NULL,
10910 "SCROLL DOWN", COB_SCREEN_SCROLL_DOWN,
10911 "SCROLL UP", COB_SCREEN_SCROLL_UP);
10912 }
10913 | TIME_OUT _after positive_id_or_lit
10914 {
10915 check_repeated (_("TIME-OUT or BEFORE TIME clauses"), SYN_CLAUSE_4,
10916 &check_duplicate);
10917 set_attribs (NULL, NULL, NULL, $3, NULL, NULL, 0);
10918 }
10919 | _control KEY _in key_dest
10920 ;
10921
10922 _key_dest: /* empty */ | key_dest;
10923
10924 key_dest:
10925 /* note: GnuCOBOL uses screenio.cpy 9(4) identifier, ACUCOBOL 99 */
10926 numeric_identifier
10927 {
10928 check_repeated ("CONTROL KEY", SYN_CLAUSE_29, &check_duplicate);
10929 CB_PENDING ("CONTROL KEY");
10930 #if 0 /* should generate the following *after* the ACCEPT is finished */
10931 cb_emit_accept_escape_key ($1);
10932 #endif
10933 }
10934 ;
10935
10936 no_echo:
10937 NO ECHO
10938 | NO_ECHO
10939 | OFF
10940 ;
10941
10942 reverse_video:
10943 REVERSE_VIDEO
10944 | REVERSED
10945 | REVERSE
10946 ;
10947
10948 update_default:
10949 UPDATE
10950 | DEFAULT
10951 ;
10952
10953 _end_accept:
10954 /* empty */ %prec SHIFT_PREFER
10955 {
10956 TERMINATOR_WARNING ($-2, ACCEPT);
10957 }
10958 | END_ACCEPT
10959 {
10960 TERMINATOR_CLEAR ($-2, ACCEPT);
10961 # if 0 /* activate only for debugging purposes for attribs
10962 FIXME: Replace by DEBUG_LOG function */
10963 if (current_statement->attr_ptr) {
10964 print_bits (current_statement->attr_ptr->dispattrs);
10965 } else {
10966 fputs("No Attribs", stderr);
10967 }
10968 #endif
10969 }
10970 ;
10971
10972
10973 /* ADD statement */
10974
10975 add_statement:
10976 ADD
10977 {
10978 begin_statement ("ADD", TERM_ADD);
10979 }
10980 add_body
10981 _end_add
10982 ;
10983
10984 add_body:
10985 x_list TO arithmetic_x_list on_size_error_phrases
10986 {
10987 cb_emit_arithmetic ($3, '+', cb_build_binary_list ($1, '+'));
10988 }
10989 | x_list _add_to GIVING arithmetic_x_list on_size_error_phrases
10990 {
10991 if ($2) {
10992 cb_list_add ($1, $2);
10993 }
10994 cb_emit_arithmetic ($4, 0, cb_build_binary_list ($1, '+'));
10995 }
10996 | CORRESPONDING identifier TO identifier flag_rounded on_size_error_phrases
10997 {
10998 cb_emit_corresponding (cb_build_add, $4, $2, $5);
10999 }
11000 | TABLE table_identifier TO table_identifier flag_rounded _from_idx_to_idx _dest_index on_size_error_phrases
11001 {
11002 CB_PENDING ("ADD TABLE");
11003 cb_emit_tab_arithmetic (cb_build_add, $4, $2, $5, $6, $7);
11004 }
11005 ;
11006
11007 _add_to:
11008 /* empty */ { $$ = NULL; }
11009 | TO x { $$ = $2; }
11010 ;
11011
11012 _end_add:
11013 /* empty */ %prec SHIFT_PREFER
11014 {
11015 TERMINATOR_WARNING ($-2, ADD);
11016 }
11017 | END_ADD
11018 {
11019 TERMINATOR_CLEAR ($-2, ADD);
11020 }
11021 ;
11022
11023
11024 /* ALLOCATE statement */
11025
11026 allocate_statement:
11027 ALLOCATE
11028 {
11029 begin_statement ("ALLOCATE", 0);
11030 cobc_cs_check = CB_CS_ALLOCATE;
11031 current_statement->flag_no_based = 1;
11032 }
11033 allocate_body
11034 ;
11035
11036 allocate_body:
11037 identifier flag_initialized _loc allocate_returning
11038 {
11039 cb_emit_allocate ($1, $4, NULL, $2);
11040 }
11041 | exp CHARACTERS flag_initialized_to _loc allocate_returning
11042 {
11043 if ($5 == NULL) {
11044 cb_error_x (CB_TREE (current_statement),
11045 _("ALLOCATE CHARACTERS requires RETURNING clause"));
11046 } else {
11047 cb_emit_allocate (NULL, $5, $1, $3);
11048 }
11049 }
11050 ;
11051
11052 _loc:
11053 /* empty */
11054 | LOC integer
11055 {
11056 int adressing = cb_get_int ($2);
11057
11058 if (adressing == 24
11059 || adressing == 31) {
11060 cb_warning (COBC_WARN_FILLER, _("ignoring %s phrase"), "LOC");
11061 } else {
11062 cb_error (_("addressing mode should be either 24 or 31 bit"));
11063 }
11064 }
11065
11066 allocate_returning:
11067 /* empty */ { $$ = NULL; }
11068 | RETURNING target_x { $$ = $2; }
11069 ;
11070
11071
11072 /* ALTER statement */
11073
11074 alter_statement:
11075 ALTER
11076 {
11077 begin_statement ("ALTER", 0);
11078 cb_verify (cb_alter_statement, "ALTER");
11079 }
11080 alter_body
11081 ;
11082
11083 alter_body:
11084 alter_entry
11085 | alter_body alter_entry
11086 ;
11087
11088 alter_entry:
11089 procedure_name TO _proceed_to procedure_name
11090 {
11091 cb_emit_alter ($1, $4);
11092 }
11093 ;
11094
11095 _proceed_to: | PROCEED TO ;
11096
11097
11098 /* CALL statement */
11099
11100 call_statement:
11101 CALL
11102 {
11103 begin_statement ("CALL", TERM_CALL);
11104 cobc_cs_check = CB_CS_CALL;
11105 call_nothing = 0;
11106 cobc_allow_program_name = 1;
11107 backup_current_pos ();
11108 }
11109 call_body
11110 _end_call
11111 {
11112 cobc_cs_check = 0;
11113 }
11114 ;
11115
11116 call_body:
11117 _mnemonic_conv _thread_start program_or_prototype
11118 {
11119 cobc_allow_program_name = 0;
11120 }
11121 _thread_handle
11122 _conv_linkage
11123 call_using
11124 call_returning
11125 call_exception_phrases
11126 {
11127 int call_conv = 0;
11128 int call_conv_local = 0;
11129
11130 if (current_program->prog_type == COB_MODULE_TYPE_PROGRAM
11131 && !current_program->flag_recursive
11132 && is_recursive_call ($3)) {
11133 cb_warning_x (COBC_WARN_FILLER, $3,
11134 _("recursive program call - assuming RECURSIVE attribute"));
11135 current_program->flag_recursive = 1;
11136 }
11137 call_conv = current_call_convention;
11138 if ($6) {
11139 if (current_call_convention & CB_CONV_STATIC_LINK) {
11140 call_conv = CB_INTEGER ($6)->val | CB_CONV_STATIC_LINK;
11141 } else {
11142 call_conv = CB_INTEGER ($6)->val;
11143 }
11144 if ($1) {
11145 /* note: $1 is likely to be a reference to SPECIAL-NAMES */
11146 cb_error_x ($6, _("%s and %s are mutually exclusive"),
11147 "CALL-CONVENTION", "WITH LINKAGE");
11148 }
11149 }
11150 if ((CB_PAIR_X ($9) != NULL)
11151 && (call_conv & CB_CONV_STATIC_LINK)) {
11152 cb_warning_x (COBC_WARN_FILLER, $3,
11153 _("STATIC CALL convention ignored because of ON EXCEPTION"));
11154 call_conv &= ~CB_CONV_STATIC_LINK;
11155 }
11156 if ($1) {
11157 if (CB_INTEGER_P ($1)) {
11158 call_conv_local = CB_INTEGER ($1)->val;
11159 if ((CB_PAIR_X ($9) != NULL)
11160 && (call_conv_local & CB_CONV_STATIC_LINK)) {
11161 cb_warning_x (COBC_WARN_FILLER, $1,
11162 _("ON EXCEPTION ignored because of STATIC CALL"));
11163 CB_PAIR_X ($9) = NULL;
11164 }
11165 call_conv |= call_conv_local;
11166 if (CB_INTEGER ($1)->val & CB_CONV_COBOL) {
11167 call_conv &= ~CB_CONV_STDCALL;
11168 } else {
11169 call_conv &= ~CB_CONV_COBOL;
11170 }
11171 } else {
11172 call_conv = cb_get_int($1);
11173 }
11174 }
11175 /* For CALL ... RETURNING NOTHING, set the call convention bit */
11176 if (call_nothing) {
11177 call_conv |= CB_CONV_NO_RET_UPD;
11178 }
11179 cb_emit_call ($3, $7, $8, CB_PAIR_X ($9), CB_PAIR_Y ($9),
11180 cb_int (call_conv), $2, $5, backup_source_line);
11181 }
11182 ;
11183
11184 _conv_linkage:
11185 /* empty */
11186 {
11187 $$ = NULL;
11188 }
11189 | WITH
11190 {
11191 /* FIXME: hack - fake cs for context-sensitive WITH ... LINKAGE */
11192 cobc_cs_check |= CB_CS_OPTIONS;
11193 backup_current_pos ();
11194 }
11195 conv_linkage_option LINKAGE
11196 {
11197 $$ = $3;
11198 restore_backup_pos ($$);
11199 cobc_cs_check ^= CB_CS_OPTIONS;
11200 cb_verify_x ($$, cb_call_convention_linkage, "WITH ... LINKAGE");
11201 }
11202 ;
11203
11204 conv_linkage_option:
11205 STDCALL
11206 {
11207 $$ = cb_int (CB_CONV_STDCALL);
11208 }
11209 | C
11210 {
11211 $$ = cb_int (CB_CONV_C);
11212 }
11213 | PASCAL
11214 {
11215 $$ = cb_int (CB_CONV_PASCAL);
11216 }
11217 ;
11218
11219 _mnemonic_conv:
11220 /* empty */
11221 {
11222 $$ = NULL;
11223 }
11224 | mnemonic_conv
11225 {
11226 cb_verify (cb_call_convention_mnemonic, "CALL-/ENTRY-CONVENTION");
11227 $$ = $1;
11228 }
11229 ;
11230
11231 mnemonic_conv:
11232 STATIC /* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
11233 {
11234 if (current_call_convention & CB_CONV_COBOL) {
11235 $$ = cb_int (CB_CONV_STATIC_LINK | CB_CONV_COBOL);
11236 } else {
11237 $$ = cb_int (CB_CONV_STATIC_LINK);
11238 }
11239 }
11240 | STDCALL /* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
11241 {
11242 $$ = cb_int (CB_CONV_STDCALL);
11243 }
11244 | C /* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
11245 {
11246 $$ = cb_int (CB_CONV_C);
11247 }
11248 | TOK_EXTERN /* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
11249 {
11250 $$ = cb_int (CB_CONV_C);
11251 }
11252 | PASCAL /* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
11253 {
11254 $$ = cb_int (CB_CONV_PASCAL);
11255 }
11256 | MNEMONIC_NAME
11257 {
11258 cb_tree x;
11259
11260 x = cb_ref ($1);
11261 if (CB_VALID_TREE (x)) {
11262 if (CB_SYSTEM_NAME(x)->token != CB_FEATURE_CONVENTION) {
11263 cb_error_x ($1, _("invalid mnemonic name"));
11264 $$ = NULL;
11265 } else {
11266 $$ = CB_SYSTEM_NAME(x)->value;
11267 }
11268 } else {
11269 $$ = NULL;
11270 }
11271 }
11272 ;
11273
11274 program_or_prototype:
11275 id_or_lit_or_func
11276 {
11277 if (CB_LITERAL_P ($1)) {
11278 cb_trim_program_id ($1);
11279 }
11280 }
11281 | _id_or_lit_or_func_as nested_or_prototype
11282 {
11283 cb_verify (cb_program_prototypes, _("CALL/CANCEL with program-prototype-name"));
11284 /* hack to push the prototype name */
11285 if ($2 && CB_REFERENCE_P ($2)) {
11286 if ($1) {
11287 cb_warning_x (COBC_WARN_FILLER, $1, _("id/literal ignored, using prototype name"));
11288 }
11289 $$ = $2;
11290 } else if ($1 && CB_LITERAL_P ($1)) {
11291 $$ = $1;
11292 } else {
11293 cb_error (_("NESTED phrase is only valid with literal"));
11294 $$ = cb_error_node;
11295 }
11296 }
11297 ;
11298
11299 _id_or_lit_or_func_as:
11300 /* empty */
11301 {
11302 $$ = NULL;
11303 }
11304 |
11305 id_or_lit_or_func AS
11306 {
11307 if (CB_LITERAL_P ($1)) {
11308 cb_trim_program_id ($1);
11309 }
11310 $$ = $1;
11311 }
11312 ;
11313
11314 nested_or_prototype:
11315 NESTED
11316 {
11317 CB_PENDING ("NESTED phrase for CALL statement");
11318 }
11319 | PROGRAM_NAME
11320 ;
11321
11322 call_using:
11323 /* empty */
11324 {
11325 $$ = NULL;
11326 }
11327 | USING
11328 {
11329 call_mode = CB_CALL_BY_REFERENCE;
11330 size_mode = CB_SIZE_4;
11331 }
11332 call_param_list
11333 {
11334 if (cb_list_length ($3) > MAX_CALL_FIELD_PARAMS) {
11335 cb_error_x (CB_TREE (current_statement),
11336 _("number of arguments exceeds maximum %d"),
11337 MAX_CALL_FIELD_PARAMS);
11338 }
11339 $$ = $3;
11340 }
11341 ;
11342
11343 call_param_list:
11344 call_param { $$ = $1; }
11345 | call_param_list
11346 call_param { $$ = cb_list_append ($1, $2); }
11347 ;
11348
11349 call_param:
11350 _call_type OMITTED
11351 {
11352 if (call_mode != CB_CALL_BY_REFERENCE) {
11353 cb_error_x (CB_TREE (current_statement),
11354 _("OMITTED only allowed when arguments are passed BY REFERENCE"));
11355 }
11356 $$ = CB_BUILD_PAIR (cb_int (call_mode), cb_null);
11357 }
11358 | _call_type _size_optional call_x
11359 {
11360 int save_mode; /* internal single parameter only mode */
11361
11362 save_mode = call_mode;
11363 if (call_mode != CB_CALL_BY_REFERENCE) {
11364 if (CB_FILE_P ($3) || (CB_REFERENCE_P ($3) &&
11365 CB_FILE_P (CB_REFERENCE ($3)->value))) {
11366 cb_error_x (CB_TREE (current_statement),
11367 _("invalid file name reference"));
11368 } else if (call_mode == CB_CALL_BY_VALUE) {
11369 /* FIXME: compiler configuration needed, IBM allows one-byte
11370 alphanumeric items [--> a `char`], too, while
11371 COBOL 2002/2014 allow only numeric literals
11372 --> revise after rw-merge */
11373 if (cb_category_is_alpha ($3)) {
11374 cb_warning_x (COBC_WARN_FILLER, $3,
11375 _("BY CONTENT assumed for alphanumeric item '%s'"),
11376 cb_name ($3));
11377 call_mode = CB_CALL_BY_CONTENT;
11378 } else if (cb_category_is_national ($3)) {
11379 cb_warning_x (COBC_WARN_FILLER, $3,
11380 _("BY CONTENT assumed for national item '%s'"),
11381 cb_name ($3));
11382 call_mode = CB_CALL_BY_CONTENT;
11383 }
11384 }
11385 }
11386 $$ = CB_BUILD_PAIR (cb_int (call_mode), $3);
11387 CB_SIZES ($$) = size_mode;
11388 call_mode = save_mode;
11389 }
11390 ;
11391
11392 _call_type:
11393 /* empty */
11394 | _by REFERENCE
11395 {
11396 call_mode = CB_CALL_BY_REFERENCE;
11397 }
11398 | _by CONTENT
11399 {
11400 if (current_program->flag_chained) {
11401 cb_error_x (CB_TREE (current_statement),
11402 _("%s not allowed in CHAINED programs"), "BY CONTENT");
11403 } else {
11404 call_mode = CB_CALL_BY_CONTENT;
11405 }
11406 }
11407 | _by VALUE
11408 {
11409 if (current_program->flag_chained) {
11410 cb_error_x (CB_TREE (current_statement),
11411 _("%s not allowed in CHAINED programs"), "BY VALUE");
11412 } else {
11413 call_mode = CB_CALL_BY_VALUE;
11414 }
11415 }
11416 ;
11417
11418 call_returning:
11419 /* empty */
11420 {
11421 $$ = NULL;
11422 }
11423 | return_give _into identifier
11424 {
11425 $$ = $3;
11426 }
11427 | return_give null_or_omitted
11428 {
11429 $$ = cb_null;
11430 }
11431 | return_give NOTHING
11432 {
11433 call_nothing = CB_CONV_NO_RET_UPD;
11434 $$ = cb_null;
11435 }
11436 | return_give ADDRESS _of identifier
11437 {
11438 struct cb_field *f;
11439
11440 if (cb_ref ($4) != cb_error_node) {
11441 f = CB_FIELD_PTR ($4);
11442 if (f->level != 1 && f->level != 77) {
11443 cb_error (_("RETURNING item must have level 01 or 77"));
11444 $$ = NULL;
11445 } else if (f->storage != CB_STORAGE_LINKAGE &&
11446 !f->flag_item_based) {
11447 cb_error (_("RETURNING item must be a LINKAGE SECTION item or have BASED clause"));
11448 $$ = NULL;
11449 } else {
11450 $$ = cb_build_address ($4);
11451 }
11452 } else {
11453 $$ = NULL;
11454 }
11455 }
11456 ;
11457
11458 return_give:
11459 RETURNING
11460 | GIVING
11461 ;
11462
11463 null_or_omitted:
11464 TOK_NULL
11465 | OMITTED
11466 ;
11467
11468 call_exception_phrases:
11469 %prec SHIFT_PREFER
11470 {
11471 $$ = CB_BUILD_PAIR (NULL, NULL);
11472 }
11473 | call_on_exception _call_not_on_exception
11474 {
11475 $$ = CB_BUILD_PAIR ($1, $2);
11476 }
11477 | call_not_on_exception _call_on_exception
11478 {
11479 if ($2) {
11480 cb_verify (cb_not_exception_before_exception,
11481 _("NOT EXCEPTION before EXCEPTION"));
11482 }
11483 $$ = CB_BUILD_PAIR ($2, $1);
11484 }
11485 ;
11486
11487 _call_on_exception:
11488 %prec SHIFT_PREFER
11489 {
11490 $$ = NULL;
11491 }
11492 | call_on_exception
11493 {
11494 $$ = $1;
11495 }
11496 ;
11497
11498 call_on_exception:
11499 EXCEPTION statement_list
11500 {
11501 $$ = $2;
11502 }
11503 | TOK_OVERFLOW statement_list
11504 {
11505 cb_verify (cb_call_overflow, "ON OVERFLOW");
11506 $$ = $2;
11507 }
11508 ;
11509
11510 _call_not_on_exception:
11511 %prec SHIFT_PREFER
11512 {
11513 $$ = NULL;
11514 }
11515 | call_not_on_exception
11516 {
11517 $$ = $1;
11518 }
11519 ;
11520
11521 call_not_on_exception:
11522 NOT_EXCEPTION statement_list
11523 {
11524 $$ = $2;
11525 }
11526 ;
11527
11528 _end_call:
11529 /* empty */ %prec SHIFT_PREFER
11530 {
11531 TERMINATOR_WARNING ($-2, CALL);
11532 }
11533 | END_CALL
11534 {
11535 TERMINATOR_CLEAR ($-2, CALL);
11536 }
11537 ;
11538
11539
11540 /* CANCEL statement */
11541
11542 cancel_statement:
11543 CANCEL
11544 {
11545 begin_statement ("CANCEL", 0);
11546 cobc_allow_program_name = 1;
11547 }
11548 cancel_body
11549 {
11550 cobc_allow_program_name = 0;
11551 }
11552 ;
11553
11554 cancel_body:
11555 id_or_lit_or_program_name
11556 {
11557 cb_emit_cancel ($1);
11558 }
11559 | cancel_body id_or_lit_or_program_name
11560 {
11561 cb_emit_cancel ($2);
11562 }
11563 ;
11564
11565 id_or_lit_or_program_name:
11566 id_or_lit
11567 | PROGRAM_NAME
11568 {
11569 cb_verify (cb_program_prototypes, _("CALL/CANCEL with program-prototype-name"));
11570 }
11571 ;
11572
11573 /* CLOSE statement */
11574
11575 close_statement:
11576 CLOSE
11577 {
11578 begin_statement ("CLOSE", 0);
11579 }
11580 close_body
11581 ;
11582
11583 close_body:
11584 close_files
11585 | close_window
11586 ;
11587
11588 close_files:
11589 file_name _close_option
11590 {
11591 #if 0 /* CHECKME: likely not needed */
11592 begin_implicit_statement ();
11593 #endif
11594 cb_emit_close ($1, $2);
11595 }
11596 | close_files file_name _close_option
11597 {
11598 begin_implicit_statement ();
11599 cb_emit_close ($2, $3);
11600 }
11601 ;
11602
11603 _close_option:
11604 /* empty */ { $$ = cb_int (COB_CLOSE_NORMAL); }
11605 | reel_or_unit { $$ = cb_int (COB_CLOSE_UNIT); }
11606 | reel_or_unit _for REMOVAL { $$ = cb_int (COB_CLOSE_UNIT_REMOVAL); }
11607 | _with NO REWIND { $$ = cb_int (COB_CLOSE_NO_REWIND); }
11608 | _with LOCK { $$ = cb_int (COB_CLOSE_LOCK); }
11609 ;
11610
11611 close_window:
11612 WINDOW
11613 {
11614 CB_PENDING ("GRAPHICAL WINDOW");
11615 current_statement->name = "CLOSE WINDOW";
11616 }
11617 identifier _close_display_option
11618 {
11619 cb_emit_close_window ($3, $4);
11620 }
11621 ;
11622
11623 _close_display_option:
11624 /* empty */ { $$ = NULL; }
11625 | _with NO DISPLAY { $$ = cb_int0; }
11626 ;
11627
11628
11629 /* COMPUTE statement */
11630
11631 compute_statement:
11632 COMPUTE
11633 {
11634 begin_statement ("COMPUTE", TERM_COMPUTE);
11635 }
11636 compute_body
11637 _end_compute
11638 ;
11639
11640 compute_body:
11641 arithmetic_x_list comp_equal exp on_size_error_phrases
11642 {
11643 cb_emit_arithmetic ($1, 0, $3);
11644 }
11645 ;
11646
11647 _end_compute:
11648 /* empty */ %prec SHIFT_PREFER
11649 {
11650 TERMINATOR_WARNING ($-2, COMPUTE);
11651 }
11652 | END_COMPUTE
11653 {
11654 TERMINATOR_CLEAR ($-2, COMPUTE);
11655 }
11656 ;
11657
11658
11659 /* COMMIT statement */
11660
11661 commit_statement:
11662 COMMIT
11663 {
11664 begin_statement ("COMMIT", 0);
11665 cb_emit_commit ();
11666 }
11667 ;
11668
11669
11670 /* CONTINUE statement */
11671
11672 continue_statement:
11673 CONTINUE
11674 {
11675 backup_current_pos ();
11676 }
11677 _continue_after_phrase
11678 {
11679 if (!$3) {
11680 /* Do not check unreached for CONTINUE without after phrase */
11681 unsigned int save_unreached = check_unreached;
11682 check_unreached = 0;
11683 begin_statement_from_backup_pos ("CONTINUE", 0);
11684 cb_emit_continue (NULL);
11685 check_unreached = save_unreached;
11686 } else {
11687 begin_statement_from_backup_pos ("CONTINUE AFTER", 0);
11688 cb_emit_continue ($3);
11689 }
11690 }
11691 ;
11692
11693 _continue_after_phrase:
11694 /* empty */ { $$ = NULL;}
11695 | AFTER {
11696 /* FIXME: hack - fake cs for context-sensitive SECONDS */
11697 cobc_cs_check = CB_CS_RETRY;
11698 }
11699 exp SECONDS
11700 {
11701 $$ = $3;
11702 }
11703 ;
11704
11705
11706 /* DESTROY statement */
11707
11708 destroy_statement:
11709 DESTROY
11710 {
11711 begin_statement ("DESTROY", 0);
11712 CB_PENDING ("GRAPHICAL CONTROL");
11713 }
11714 destroy_body
11715 ;
11716
11717 destroy_body:
11718 ALL _controls
11719 {
11720 cb_emit_destroy (NULL);
11721 }
11722 /* TODO for later: add Format 3, mixing identifier_list
11723 with positions like in DISPLAY
11724 (and error on this, destroy on position is bad...) */
11725 | identifier_list
11726 {
11727 cb_emit_destroy ($1);
11728 }
11729 ;
11730
11731
11732 /* DELETE statement */
11733
11734 delete_statement:
11735 DELETE
11736 {
11737 begin_statement ("DELETE", TERM_DELETE);
11738 }
11739 delete_body
11740 _end_delete
11741 ;
11742
11743 delete_body:
11744 file_name _record _retry_phrase _invalid_key_phrases
11745 {
11746 cb_emit_delete ($1);
11747 }
11748 | TOK_FILE delete_file_list
11749 ;
11750
11751 delete_file_list:
11752 file_name
11753 {
11754 #if 0 /* CHECKME: likely not needed */
11755 begin_implicit_statement ();
11756 #endif
11757 cb_emit_delete_file ($1);
11758 }
11759 | delete_file_list file_name
11760 {
11761 begin_implicit_statement ();
11762 cb_emit_delete_file ($2);
11763 }
11764 ;
11765
11766 _end_delete:
11767 /* empty */ %prec SHIFT_PREFER
11768 {
11769 TERMINATOR_WARNING ($-2, DELETE);
11770 }
11771 | END_DELETE
11772 {
11773 TERMINATOR_CLEAR ($-2, DELETE);
11774 }
11775 ;
11776
11777
11778 /* DISABLE statement (COMMUNICATION) */
11779
11780 disable_statement:
11781 DISABLE
11782 {
11783 begin_statement ("DISABLE", 0);
11784 }
11785 enable_disable_handling
11786 ;
11787
11788
11789 enable_disable_handling:
11790 communication_mode cd_name _enable_disable_key
11791 ;
11792
11793 _enable_disable_key:
11794 /* empty */
11795 | _with KEY id_or_lit
11796 {
11797 /* Add cb_verify for <= COBOL-85 */
11798 }
11799 ;
11800
11801 communication_mode:
11802 /* empty */ /* RM-COBOL extension */
11803 | INPUT _terminal
11804 | OUTPUT
11805 | I_O TERMINAL
11806 | TERMINAL /* RM-COBOL extension */
11807 ;
11808
11809
11810 /* DISPLAY statement */
11811
11812 display_statement:
11813 DISPLAY
11814 {
11815 begin_statement ("DISPLAY", TERM_DISPLAY);
11816 cobc_cs_check = CB_CS_DISPLAY;
11817 display_type = UNKNOWN_DISPLAY;
11818 is_first_display_item = 1;
11819 }
11820 display_body
11821 _end_display
11822 ;
11823
11824 display_body:
11825 id_or_lit UPON_ENVIRONMENT_NAME _display_exception_phrases
11826 {
11827 cb_emit_env_name ($1);
11828 }
11829 | id_or_lit UPON_ENVIRONMENT_VALUE _display_exception_phrases
11830 {
11831 cb_emit_env_value ($1);
11832 }
11833 | id_or_lit UPON_ARGUMENT_NUMBER _display_exception_phrases
11834 {
11835 cb_emit_arg_number ($1);
11836 }
11837 | id_or_lit UPON_COMMAND_LINE _display_exception_phrases
11838 {
11839 cb_emit_command_line ($1);
11840 }
11841 | screen_or_device_display _display_exception_phrases
11842 | display_erase /* note: may also be part of display_pos_specifier */
11843 | display_pos_specifier
11844 | display_message_box
11845 | display_window
11846 | display_floating_window
11847 | display_initial_window
11848 ;
11849
11850 screen_or_device_display:
11851 display_list _x_list
11852 {
11853 if ($2 != NULL) {
11854 error_if_different_display_type ($2, NULL, NULL, NULL);
11855 cb_emit_display ($2, NULL, cb_int1, NULL, NULL, 0,
11856 display_type);
11857 }
11858 }
11859 | x_list
11860 {
11861 set_display_type ($1, NULL, NULL, NULL);
11862 cb_emit_display ($1, NULL, cb_int1, NULL, NULL, 1,
11863 display_type);
11864 }
11865 ;
11866
11867 display_list:
11868 display_atom
11869 | display_list display_atom
11870 ;
11871
11872 display_atom:
11873 disp_list
11874 {
11875 check_duplicate = 0;
11876 check_line_col_duplicate = 0;
11877 advancing_value = cb_int1;
11878 upon_value = NULL;
11879 line_column = NULL;
11880 }
11881 display_clauses
11882 {
11883 if ($1 == cb_null) {
11884 /* Emit DISPLAY OMITTED. */
11885 CB_UNFINISHED_X (CB_TREE(current_statement), "DISPLAY OMITTED");
11886 error_if_no_advancing_in_screen_display (advancing_value);
11887 }
11888
11889 /* Emit device or screen DISPLAY. */
11890
11891 /*
11892 Check that disp_list does not contain an invalid mix of fields.
11893 */
11894 if (display_type == UNKNOWN_DISPLAY) {
11895 set_display_type ($1, upon_value, line_column,
11896 current_statement->attr_ptr);
11897 } else {
11898 error_if_different_display_type ($1, upon_value,
11899 line_column,
11900 current_statement->attr_ptr);
11901 }
11902
11903 if (display_type == SCREEN_DISPLAY
11904 || display_type == FIELD_ON_SCREEN_DISPLAY) {
11905 error_if_no_advancing_in_screen_display (advancing_value);
11906 }
11907
11908 cb_emit_display ($1, upon_value, advancing_value, line_column,
11909 current_statement->attr_ptr,
11910 is_first_display_item, display_type);
11911
11912 is_first_display_item = 0;
11913 }
11914 ;
11915
11916 disp_list:
11917 x_list
11918 {
11919 $$ = $1;
11920 }
11921 | OMITTED
11922 {
11923 $$ = cb_null;
11924 }
11925 ;
11926
11927 _with_display_attr:
11928 /* empty */
11929 | WITH display_attrs
11930 ;
11931
11932 display_attrs:
11933 disp_attr
11934 | display_attrs disp_attr
11935 ;
11936
11937 display_clauses:
11938 display_clause
11939 | display_clauses display_clause
11940 ;
11941
11942 display_clause:
11943 display_upon
11944 {
11945 check_repeated ("UPON", SYN_CLAUSE_1, &check_duplicate);
11946 }
11947 | _with NO_ADVANCING
11948 {
11949 check_repeated ("NO ADVANCING", SYN_CLAUSE_2, &check_duplicate);
11950 advancing_value = cb_int0;
11951 }
11952 | mode_is_block
11953 {
11954 check_repeated ("MODE IS BLOCK", SYN_CLAUSE_3, &check_duplicate);
11955 }
11956 | at_line_column
11957 | _with disp_attr
11958 ;
11959
11960 _display_upon:
11961 /* empty */
11962 {
11963 upon_value = NULL;
11964 }
11965 | display_upon
11966 ;
11967
11968 display_upon:
11969 UPON mnemonic_name
11970 {
11971 upon_value = cb_build_display_mnemonic ($2);
11972 }
11973 | UPON WORD
11974 {
11975 upon_value = cb_build_display_name ($2);
11976 }
11977 | UPON PRINTER
11978 {
11979 upon_value = cb_int2;
11980 }
11981 | UPON crt_under
11982 {
11983 upon_value = cb_null;
11984 }
11985 ;
11986
11987 crt_under:
11988 CRT
11989 | CRT_UNDER
11990 ;
11991
11992 display_erase:
11993 ERASE
11994 {
11995 check_duplicate = SYN_CLAUSE_10;
11996 check_line_col_duplicate = 0;
11997 line_column = NULL;
11998 set_dispattr_with_conflict ("ERASE EOS", COB_SCREEN_ERASE_EOS,
11999 "ERASE EOL", COB_SCREEN_ERASE_EOL);
12000 }
12001 _with_display_attr
12002 {
12003 cb_emit_display (CB_LIST_INIT (cb_space), cb_null, cb_int1, line_column, NULL, 1, FIELD_ON_SCREEN_DISPLAY);
12004 }
12005 ;
12006
12007 display_pos_specifier:
12008 /* FIXME: the actual correct version (according to MicroFocus "MS compiler" option)
12009 would allow combination of multiple formats ...*/
12010 field_or_literal_or_erase_with_pos_specifier _with_display_attr
12011 {
12012 cb_emit_display ($1, cb_null, cb_int1, line_column, NULL, 1, FIELD_ON_SCREEN_DISPLAY);
12013 }
12014 ;
12015
12016 field_or_literal_or_erase_with_pos_specifier:
12017 {
12018 check_duplicate = 0;
12019 check_line_col_duplicate = 0;
12020 line_column = NULL;
12021 }
12022 pos_specifier field_or_literal_or_erase_list
12023 {
12024 $$ = $3;
12025 }
12026 ;
12027
12028 field_or_literal_or_erase_list:
12029 field_or_literal_or_erase
12030 {
12031 $$ = CB_LIST_INIT ($1);
12032 }
12033 | field_or_literal_or_erase_list field_or_literal_or_erase
12034 {
12035 $$ = cb_list_add ($1, $2);
12036 }
12037 ;
12038
12039
12040 field_or_literal_or_erase:
12041 identifier
12042 | basic_literal
12043 | ERASE
12044 {
12045 set_dispattr_with_conflict ("ERASE EOS", COB_SCREEN_ERASE_EOS,
12046 "ERASE EOL", COB_SCREEN_ERASE_EOL);
12047 $$ = cb_space;
12048 }
12049 ;
12050
12051
12052 display_message_box:
12053 MESSAGE _box x_list
12054 {
12055 CB_UNFINISHED_X (CB_TREE(current_statement), "DISPLAY MESSAGE");
12056 upon_value = NULL;
12057 }
12058 _display_message_clauses
12059 {
12060 /* for now: minimal support for display and prompt only */
12061 if (upon_value) {
12062 cb_emit_display (CB_LIST_INIT (upon_value), NULL, NULL, NULL,
12063 NULL, 1, FIELD_ON_SCREEN_DISPLAY);
12064 }
12065 cb_emit_display ($3, NULL, NULL, NULL,
12066 NULL, 1, FIELD_ON_SCREEN_DISPLAY);
12067 cb_emit_accept (cb_null, NULL, NULL);
12068 }
12069 ;
12070
12071 _display_message_clauses:
12072 /* empty */
12073 | display_message_clauses
12074 ;
12075
12076 display_message_clauses:
12077 display_message_clause
12078 | display_message_clauses display_message_clause
12079 ;
12080
12081 display_message_clause:
12082 TITLE _is_equal x
12083 {
12084 upon_value = $3;
12085 }
12086 | TYPE _is_equal x
12087 | ICON _is_equal x
12088 | DEFAULT _is_equal x
12089 | return_give x
12090 ;
12091
12092 display_window:
12093 sub_or_window
12094 {
12095 CB_PENDING ("GRAPHICAL WINDOW");
12096 current_statement->name = "DISPLAY WINDOW";
12097 }
12098 _upon_window_handle
12099 {
12100 check_duplicate = 0;
12101 check_line_col_duplicate = 0;
12102 line_column = NULL;
12103 upon_value = NULL; /* Hack: stores the POP-UP AREA */
12104 }
12105 display_window_clauses
12106 {
12107 cb_emit_display_window (NULL, upon_value, $3, line_column,
12108 current_statement->attr_ptr);
12109 }
12110 ;
12111
12112 sub_or_window:
12113 WINDOW
12114 | SUBWINDOW
12115 ;
12116
12117 display_floating_window:
12118 FLOATING _graphical WINDOW
12119 {
12120 CB_PENDING ("GRAPHICAL WINDOW");
12121 current_statement->name = "DISPLAY FLOATING WINDOW";
12122 }
12123 _upon_window_handle
12124 {
12125 check_duplicate = 0;
12126 check_line_col_duplicate = 0;
12127 line_column = NULL;
12128 upon_value = NULL; /* Hack: stores the POP-UP AREA */
12129 }
12130 display_window_clauses
12131 {
12132 if ($2) {
12133 /* TODO: set "CELL WIDTH" and "CELL HEIGHT" to "LABEL FONT" */
12134 /* if not set already */
12135 }
12136 cb_emit_display_window (cb_int0, upon_value, $5, line_column,
12137 current_statement->attr_ptr);
12138 }
12139 ;
12140
12141 display_initial_window:
12142 initial_type _graphical WINDOW
12143 {
12144 CB_PENDING ("GRAPHICAL WINDOW");
12145 current_statement->name = "DISPLAY INITIAL WINDOW";
12146 check_duplicate = 0;
12147 check_line_col_duplicate = 0;
12148 line_column = NULL;
12149 upon_value = NULL; /* Hack: stores the POP-UP AREA */
12150 /* TODO: initialize attributes for SHADOW, BOTTOM */
12151 }
12152 display_window_clauses
12153 {
12154 if ($2) {
12155 /* TODO: set "CELL WIDTH" and "CELL HEIGHT" to "LABEL FONT" */
12156 /* if not set already */
12157 }
12158 cb_emit_display_window ($1, upon_value, NULL, line_column,
12159 current_statement->attr_ptr);
12160 }
12161 ;
12162
12163 initial_type:
12164 TOK_INITIAL {$$ = cb_int1;}
12165 | STANDARD {$$ = cb_int2;}
12166 | INDEPENDENT {$$ = cb_int3;}
12167 ;
12168
12169 _graphical:
12170 /* empty */ {$$ = NULL;}
12171 | GRAPHICAL {$$ = cb_int1;}
12172 ;
12173
12174 _upon_window_handle:
12175 /* empty */
12176 {
12177 $$ = NULL;
12178 }
12179 | UPON identifier
12180 {
12181 $$ = $2;
12182 }
12183 ;
12184
12185 window_handle:
12186 identifier
12187 {
12188 struct cb_field *f;
12189
12190 if (cb_ref ($1) != cb_error_node) {
12191 f = CB_FIELD_PTR ($1);
12192 if (f->usage != CB_USAGE_HNDL_WINDOW
12193 && f->usage != CB_USAGE_HNDL_SUBWINDOW) {
12194 cb_error_x ($1, _("HANDLE must be a %s HANDLE"), "WINDOW");
12195 }
12196 }
12197 $$ = $1;
12198 }
12199 | WINDOW identifier
12200 {
12201 struct cb_field *f;
12202
12203 if (cb_ref ($2) != cb_error_node) {
12204 f = CB_FIELD_PTR ($2);
12205 if (f->usage != CB_USAGE_HNDL) {
12206 cb_error_x ($2, _("HANDLE must be a generic HANDLE"));
12207 }
12208 }
12209 $$ = $2;
12210 }
12211 | WINDOW /* current window */
12212 {
12213 $$ = cb_null;
12214 }
12215 ;
12216
12217 display_window_clauses:
12218 display_window_clause
12219 | display_window_clauses display_window_clause
12220 ;
12221
12222 /* FIXME: has different clauses (some additional while some aren't in)
12223 SCREEN is optional(=implied) for ERASE here */
12224 display_window_clause:
12225 pop_up_or_handle /* DISPLAY WINDOW actually only takes POP-UP */
12226 | LINES num_id_or_lit
12227 {
12228 /* TODO: store */
12229 }
12230 | at_line_column
12231 | _top_or_bottom _left_or_centered_or_right TITLE _is_equal x
12232 | shadow
12233 | boxed
12234 | no_scroll_wrap
12235 | _with disp_attr
12236 ;
12237
12238 shadow:
12239 SHADOW { /* TODO: set attribute */ }
12240 ;
12241 boxed:
12242 BOXED { /* TODO: set attribute */ }
12243 ;
12244
12245 _top_or_bottom:
12246 /* empty */ { $$ = cb_int0; }
12247 | TOP { $$ = cb_int0; }
12248 | BOTTOM { $$ = cb_int1; }
12249 ;
12250
12251 _left_or_centered_or_right:
12252 LEFT { $$ = cb_int0; }
12253 | CENTERED { $$ = cb_int1; }
12254 | /* empty */ { $$ = cb_int1; }
12255 | RIGHT { $$ = cb_int2; }
12256 ;
12257
12258 no_scroll_wrap:
12259 _with NO SCROLL
12260 | _with NO WRAP
12261 ;
12262
12263
12264 pop_up_or_handle:
12265 pop_up_area
12266 | handle_is_in
12267 ;
12268
12269 pop_up_area:
12270 POP_UP _area _is_equal identifier
12271 {
12272 if (upon_value) {
12273 emit_duplicate_clause_message("POP-UP AREA");
12274 }
12275 upon_value = $4;
12276 }
12277 ;
12278
12279 handle_is_in:
12280 HANDLE _is_in identifier
12281 {
12282 if (!strcmp (current_statement->name, "DISPLAY WINDOW")) {
12283 cb_error_x ($3, _("HANDLE clause invalid for %s"),
12284 current_statement->name);
12285 upon_value = cb_error_node;
12286 } else{
12287 if (upon_value) {
12288 emit_duplicate_clause_message("POP-UP AREA / HANDLE IN");
12289 }
12290 upon_value = $3;
12291 }
12292 }
12293 ;
12294
12295 disp_attr:
12296 BELL
12297 {
12298 check_repeated ("BELL", SYN_CLAUSE_4, &check_duplicate);
12299 set_dispattr (COB_SCREEN_BELL);
12300 }
12301 | BLANK LINE
12302 {
12303 check_repeated ("BLANK LINE", SYN_CLAUSE_5, &check_duplicate);
12304 set_dispattr_with_conflict ("BLANK LINE", COB_SCREEN_BLANK_LINE,
12305 "BLANK SCREEN", COB_SCREEN_BLANK_SCREEN);
12306 }
12307 | BLANK SCREEN
12308 {
12309 check_repeated ("BLANK SCREEN", SYN_CLAUSE_6, &check_duplicate);
12310 set_dispattr_with_conflict ("BLANK SCREEN", COB_SCREEN_BLANK_SCREEN,
12311 "BLANK LINE", COB_SCREEN_BLANK_LINE);
12312 }
12313 | BLINK
12314 {
12315 check_repeated ("BLINK", SYN_CLAUSE_7, &check_duplicate);
12316 set_dispattr (COB_SCREEN_BLINK);
12317 }
12318 | CONVERSION
12319 {
12320 check_repeated ("CONVERSION", SYN_CLAUSE_8, &check_duplicate);
12321 cb_warning (COBC_WARN_FILLER, _("ignoring %s phrase"), "CONVERSION");
12322 }
12323 | ERASE eol
12324 {
12325 check_repeated ("ERASE EOL", SYN_CLAUSE_9, &check_duplicate);
12326 set_dispattr_with_conflict ("ERASE EOL", COB_SCREEN_ERASE_EOL,
12327 "ERASE EOS", COB_SCREEN_ERASE_EOS);
12328 }
12329 | ERASE eos
12330 {
12331 check_repeated ("ERASE EOS", SYN_CLAUSE_10, &check_duplicate);
12332 set_dispattr_with_conflict ("ERASE EOS", COB_SCREEN_ERASE_EOS,
12333 "ERASE EOL", COB_SCREEN_ERASE_EOL);
12334 }
12335 | HIGHLIGHT
12336 {
12337 check_repeated ("HIGHLIGHT", SYN_CLAUSE_11, &check_duplicate);
12338 set_dispattr_with_conflict ("HIGHLIGHT", COB_SCREEN_HIGHLIGHT,
12339 "LOWLIGHT", COB_SCREEN_LOWLIGHT);
12340 }
12341 | LOWLIGHT
12342 {
12343 check_repeated ("LOWLIGHT", SYN_CLAUSE_12, &check_duplicate);
12344 set_dispattr_with_conflict ("LOWLIGHT", COB_SCREEN_LOWLIGHT,
12345 "HIGHLIGHT", COB_SCREEN_HIGHLIGHT);
12346 }
12347 | SAME /* ACU (?) extension to use the video attributes
12348 currently present at the field's screen location. */
12349 {
12350 CB_PENDING ("SAME phrase");
12351 /* may not be specified along with the UNDERLINED, BLINK, REVERSED,
12352 HIGH, LOW, STANDARD, COLOR, FOREGROUND-COLOR, or BACKGROUND-COLOR phrases */
12353 }
12354 | STANDARD /* ACU extension to reset a group HIGH/LOW */
12355 {
12356 CB_PENDING ("STANDARD intensity");
12357 }
12358 | BACKGROUND_HIGH
12359 {
12360 CB_PENDING ("BACKGROUND intensity");
12361 }
12362 | BACKGROUND_LOW
12363 {
12364 CB_PENDING ("BACKGROUND intensity");
12365 }
12366 | BACKGROUND_STANDARD
12367 {
12368 CB_PENDING ("BACKGROUND intensity");
12369 }
12370 | OVERLINE
12371 {
12372 check_repeated ("OVERLINE", SYN_CLAUSE_13, &check_duplicate);
12373 set_dispattr (COB_SCREEN_OVERLINE);
12374 }
12375 | reverse_video
12376 {
12377 check_repeated ("REVERSE-VIDEO", SYN_CLAUSE_14, &check_duplicate);
12378 set_dispattr (COB_SCREEN_REVERSE);
12379 }
12380 | SIZE _is num_id_or_lit
12381 {
12382 check_repeated ("SIZE", SYN_CLAUSE_15, &check_duplicate);
12383 set_attribs (NULL, NULL, NULL, NULL, NULL, $3, 0);
12384 }
12385 | UNDERLINE
12386 {
12387 check_repeated ("UNDERLINE", SYN_CLAUSE_16, &check_duplicate);
12388 set_dispattr (COB_SCREEN_UNDERLINE);
12389 }
12390 | COLOR _is num_id_or_lit
12391 {
12392 check_repeated ("FOREGROUND-COLOR", SYN_CLAUSE_17, &check_duplicate);
12393 check_repeated ("BACKGROUND-COLOR", SYN_CLAUSE_18, &check_duplicate);
12394 CB_PENDING ("COLOR");
12395 }
12396 | FOREGROUND_COLOR _is_equal num_id_or_lit
12397 {
12398 check_repeated ("FOREGROUND-COLOR", SYN_CLAUSE_17, &check_duplicate);
12399 set_attribs ($3, NULL, NULL, NULL, NULL, NULL, 0);
12400 }
12401 | BACKGROUND_COLOR _is_equal num_id_or_lit
12402 {
12403 check_repeated ("BACKGROUND-COLOR", SYN_CLAUSE_18, &check_duplicate);
12404 set_attribs (NULL, $3, NULL, NULL, NULL, NULL, 0);
12405 }
12406 | SCROLL _up _scroll_lines
12407 {
12408 check_repeated ("SCROLL UP", SYN_CLAUSE_19, &check_duplicate);
12409 set_attribs_with_conflict (NULL, NULL, $3, NULL, NULL, NULL,
12410 "SCROLL UP", COB_SCREEN_SCROLL_UP,
12411 "SCROLL DOWN", COB_SCREEN_SCROLL_DOWN);
12412 }
12413 | SCROLL DOWN _scroll_lines
12414 {
12415 check_repeated ("SCROLL DOWN", SYN_CLAUSE_20, &check_duplicate);
12416 set_attribs_with_conflict (NULL, NULL, $3, NULL, NULL, NULL,
12417 "SCROLL DOWN", COB_SCREEN_SCROLL_DOWN,
12418 "SCROLL UP", COB_SCREEN_SCROLL_UP);
12419 }
12420 ;
12421
12422 _end_display:
12423 /* empty */ %prec SHIFT_PREFER
12424 {
12425 TERMINATOR_WARNING ($-2, DISPLAY);
12426 }
12427 | END_DISPLAY
12428 {
12429 TERMINATOR_CLEAR ($-2, DISPLAY);
12430 }
12431 ;
12432
12433
12434 /* DIVIDE statement */
12435
12436 divide_statement:
12437 DIVIDE
12438 {
12439 begin_statement ("DIVIDE", TERM_DIVIDE);
12440 }
12441 divide_body
12442 _end_divide
12443 ;
12444
12445 divide_body:
12446 x INTO arithmetic_x_list on_size_error_phrases
12447 {
12448 cb_emit_arithmetic ($3, '/', $1);
12449 }
12450 | x INTO x GIVING arithmetic_x_list on_size_error_phrases
12451 {
12452 cb_emit_arithmetic ($5, 0, cb_build_binary_op ($3, '/', $1));
12453 }
12454 | x BY x GIVING arithmetic_x_list on_size_error_phrases
12455 {
12456 cb_emit_arithmetic ($5, 0, cb_build_binary_op ($1, '/', $3));
12457 }
12458 | x INTO x GIVING arithmetic_x REMAINDER arithmetic_x on_size_error_phrases
12459 {
12460 cb_emit_divide ($3, $1, $5, $7);
12461 }
12462 | x BY x GIVING arithmetic_x REMAINDER arithmetic_x on_size_error_phrases
12463 {
12464 cb_emit_divide ($1, $3, $5, $7);
12465 }
12466 ;
12467
12468 _end_divide:
12469 /* empty */ %prec SHIFT_PREFER
12470 {
12471 TERMINATOR_WARNING ($-2, DIVIDE);
12472 }
12473 | END_DIVIDE
12474 {
12475 TERMINATOR_CLEAR ($-2, DIVIDE);
12476 }
12477 ;
12478
12479
12480 /* ENABLE statement (COMMUNICATION) */
12481
12482 enable_statement:
12483 ENABLE
12484 {
12485 begin_statement ("ENABLE", 0);
12486 }
12487 enable_disable_handling
12488 ;
12489
12490
12491 /* ENTRY statement */
12492
12493 entry_statement:
12494 ENTRY
12495 {
12496 check_unreached = 0;
12497 begin_statement ("ENTRY", 0);
12498 backup_current_pos ();
12499 }
12500 entry_body
12501 | ENTRY FOR GO TO
12502 {
12503 check_unreached = 0;
12504 begin_statement ("ENTRY FOR GO TO", 0);
12505 backup_current_pos ();
12506 }
12507 entry_goto_body
12508 ;
12509
12510 entry_body:
12511 _mnemonic_conv LITERAL _conv_linkage call_using
12512 {
12513 if (current_program->nested_level) {
12514 cb_error (_("%s is invalid in nested program"), "ENTRY");
12515 } else if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
12516 cb_error (_("%s is invalid in a user FUNCTION"), "ENTRY");
12517 } else if (cb_verify (cb_entry_statement, "ENTRY")) {
12518 cb_tree call_conv = $1;
12519 if ($3) {
12520 call_conv = $3;
12521 if ($1) {
12522 /* note: $1 is likely to be a reference to SPECIAL-NAMES */
12523 cb_error_x ($3, _("%s and %s are mutually exclusive"),
12524 "CALL-CONVENTION", "WITH LINKAGE");
12525 }
12526 }
12527 if (!cobc_check_valid_name ((char *)(CB_LITERAL ($2)->data), ENTRY_NAME)) {
12528 emit_entry ((char *)(CB_LITERAL ($2)->data), 1, $4, call_conv);
12529 }
12530 }
12531 }
12532 ;
12533
12534 entry_goto_body:
12535 LITERAL
12536 {
12537 if (cb_verify (cb_goto_entry, "ENTRY FOR GO TO")) {
12538 emit_entry_goto ((char *)(CB_LITERAL ($1)->data));
12539 }
12540 }
12541 ;
12542
12543
12544 /* EVALUATE statement */
12545
12546 evaluate_statement:
12547 EVALUATE
12548 {
12549 begin_statement ("EVALUATE", TERM_EVALUATE);
12550 eval_level++;
12551 if (eval_level >= EVAL_DEPTH) {
12552 cb_error (_("maximum evaluate depth exceeded (%d)"),
12553 EVAL_DEPTH);
12554 eval_level = 0;
12555 eval_inc = 0;
12556 eval_inc2 = 0;
12557 YYERROR;
12558 } else {
12559 for (eval_inc = 0; eval_inc < EVAL_DEPTH; ++eval_inc) {
12560 eval_check[eval_level][eval_inc] = NULL;
12561 }
12562 eval_inc = 0;
12563 eval_inc2 = 0;
12564 }
12565 cb_end_cond (cb_any);
12566 cb_save_cond ();
12567 cb_true_side ();
12568 }
12569 evaluate_body
12570 _end_evaluate
12571 ;
12572
12573 evaluate_body:
12574 evaluate_subject_list evaluate_condition_list
12575 {
12576 if (!skip_statements) {
12577 cb_emit_evaluate ($1, $2);
12578 }
12579 eval_level--;
12580 }
12581 ;
12582
12583 evaluate_subject_list:
12584 evaluate_subject { $$ = CB_LIST_INIT ($1); }
12585 | evaluate_subject_list ALSO
12586 evaluate_subject { $$ = cb_list_add ($1, $3); }
12587 ;
12588
12589 evaluate_subject:
12590 expr
12591 {
12592 $$ = $1;
12593 eval_check[eval_level][eval_inc++] = $1;
12594 if (eval_inc >= EVAL_DEPTH) {
12595 cb_error (_("maximum evaluate depth exceeded (%d)"),
12596 EVAL_DEPTH);
12597 eval_inc = 0;
12598 YYERROR;
12599 }
12600 }
12601 | TOK_TRUE
12602 {
12603 $$ = cb_true;
12604 eval_check[eval_level][eval_inc++] = NULL;
12605 if (eval_inc >= EVAL_DEPTH) {
12606 cb_error (_("maximum evaluate depth exceeded (%d)"),
12607 EVAL_DEPTH);
12608 eval_inc = 0;
12609 YYERROR;
12610 }
12611 }
12612 | TOK_FALSE
12613 {
12614 $$ = cb_false;
12615 eval_check[eval_level][eval_inc++] = cb_false;
12616 if (eval_inc >= EVAL_DEPTH) {
12617 cb_error (_("maximum evaluate depth exceeded (%d)"),
12618 EVAL_DEPTH);
12619 eval_inc = 0;
12620 YYERROR;
12621 }
12622 }
12623 ;
12624
12625 evaluate_condition_list:
12626 evaluate_case_list evaluate_other
12627 {
12628 if ($2) {
12629 $$ = cb_list_add ($1, $2);
12630 } else {
12631 $$ = $1;
12632 }
12633 }
12634 | evaluate_case_list
12635 %prec SHIFT_PREFER
12636 {
12637 $$ = $1;
12638 }
12639 ;
12640
12641 evaluate_case_list:
12642 evaluate_case { $$ = CB_LIST_INIT ($1); }
12643 | evaluate_case_list
12644 evaluate_case { $$ = cb_list_add ($1, $2); }
12645 ;
12646
12647 evaluate_case:
12648 evaluate_when_list
12649 statement_list
12650 {
12651 $$ = CB_BUILD_CHAIN ($2, $1);
12652 eval_inc2 = 0;
12653 }
12654 | evaluate_when_list END_EVALUATE
12655 {
12656 eval_inc2 = 0;
12657 cb_verify (cb_missing_statement,
12658 _("WHEN without imperative statement"));
12659 /* Note: we don't clear the EVALUATE terminator here
12660 as we'd have to skip this later
12661 [side effect: possible warning about missing terminator] */
12662 $$ = CB_BUILD_CHAIN (CB_LIST_INIT (cb_build_continue ()), $1);
12663 }
12664 | evaluate_when_list TOK_DOT
12665 {
12666 eval_inc2 = 0;
12667 cb_verify (cb_missing_statement,
12668 _("WHEN without imperative statement"));
12669 /* Put the dot token back into the stack for reparse */
12670 cb_unput_dot ();
12671 $$ = CB_BUILD_CHAIN (CB_LIST_INIT (cb_build_continue ()), $1);
12672 }
12673 ;
12674
12675 evaluate_other:
12676 WHEN OTHER
12677 statement_list
12678 {
12679 $$ = CB_BUILD_CHAIN ($3, NULL);
12680 eval_inc2 = 0;
12681 }
12682 | WHEN OTHER END_EVALUATE
12683 {
12684 eval_inc2 = 0;
12685 cb_verify (cb_missing_statement,
12686 _("WHEN OTHER without imperative statement"));
12687 /* Note: we don't clear the EVALUATE terminator here
12688 as we'd have to skip this later
12689 [side effect: possible warning about missing terminator] */
12690 $$ = NULL;
12691 }
12692 | WHEN OTHER TOK_DOT
12693 {
12694 eval_inc2 = 0;
12695 cb_verify (cb_missing_statement,
12696 _("WHEN OTHER without imperative statement"));
12697 /* Put the dot token back into the stack for reparse */
12698 cb_unput_dot ();
12699 $$ = NULL;
12700 }
12701 ;
12702
12703 evaluate_when_list:
12704 WHEN
12705 {
12706 backup_current_pos ();
12707 }
12708 evaluate_object_list
12709 {
12710 $$ = CB_LIST_INIT ($3);
12711 restore_backup_pos ($$);
12712 eval_inc2 = 0;
12713 }
12714 | evaluate_when_list
12715 WHEN
12716 {
12717 backup_current_pos ();
12718 }
12719 evaluate_object_list
12720 {
12721 $$ = cb_list_add ($1, $4);
12722 restore_backup_pos ($$);
12723 eval_inc2 = 0;
12724 }
12725 ;
12726
12727 evaluate_object_list:
12728 evaluate_object { $$ = CB_LIST_INIT ($1); }
12729 | evaluate_object_list ALSO
12730 evaluate_object { $$ = cb_list_add ($1, $3); }
12731 ;
12732
12733 evaluate_object:
12734 partial_expr _evaluate_thru_expr
12735 {
12736 cb_tree not0;
12737 cb_tree e1;
12738 cb_tree e2;
12739 cb_tree x;
12740 cb_tree parm1;
12741
12742 not0 = cb_int0;
12743 e2 = $2;
12744 x = NULL;
12745 parm1 = $1;
12746 if (eval_check[eval_level][eval_inc2]
12747 && eval_check[eval_level][eval_inc2] != cb_false) {
12748 /* Check if the first token is NOT */
12749 /* It may belong to the EVALUATE, however see */
12750 /* below when it may be part of a partial expression */
12751 if (CB_PURPOSE_INT (parm1) == '!') {
12752 /* Pop stack if subject not TRUE / FALSE */
12753 not0 = cb_int1;
12754 x = parm1;
12755 parm1 = CB_CHAIN (parm1);
12756 }
12757 /* Partial expression handling */
12758 switch (CB_PURPOSE_INT (parm1)) {
12759 /* Relational conditions */
12760 case '<':
12761 case '>':
12762 case '[':
12763 case ']':
12764 case '~':
12765 case '=':
12766 /* Class conditions */
12767 case '9':
12768 case 'A':
12769 case 'L':
12770 case 'U':
12771 case 'P':
12772 case 'N':
12773 case 'O':
12774 case 'C':
12775 if (e2) {
12776 cb_error_x (e2, _("invalid THROUGH usage"));
12777 e2 = NULL;
12778 }
12779 not0 = CB_PURPOSE (parm1);
12780 if (x) {
12781 /* Rebind the NOT to the partial expression */
12782 parm1 = cb_build_list (cb_int ('!'), NULL, parm1);
12783 }
12784 /* Insert subject at head of list */
12785 parm1 = cb_build_list (cb_int ('x'),
12786 eval_check[eval_level][eval_inc2], parm1);
12787 break;
12788 }
12789 }
12790
12791 /* Build expr now */
12792 e1 = cb_build_expr (parm1);
12793
12794 eval_inc2++;
12795 $$ = CB_BUILD_PAIR (not0, CB_BUILD_PAIR (e1, e2));
12796
12797 if (eval_check[eval_level][eval_inc2-1] == cb_false) {
12798 /* It was EVALUATE FALSE; So flip condition */
12799 if (e1 == cb_true)
12800 e1 = cb_false;
12801 else if (e1 == cb_false)
12802 e1 = cb_true;
12803 }
12804 cb_terminate_cond ();
12805 cb_end_cond (e1);
12806 cb_save_cond ();
12807 cb_true_side ();
12808 }
12809 | ANY { $$ = cb_any; eval_inc2++; }
12810 | TOK_TRUE { $$ = cb_true; eval_inc2++; }
12811 | TOK_FALSE { $$ = cb_false; eval_inc2++; }
12812 | error { $$ = cb_error_node; eval_inc2++; }
12813 ;
12814
12815 _evaluate_thru_expr:
12816 /* empty */ { $$ = NULL; }
12817 | THRU expr { $$ = $2; }
12818 ;
12819
12820 _end_evaluate:
12821 /* empty */ %prec SHIFT_PREFER
12822 {
12823 TERMINATOR_WARNING ($-2, EVALUATE);
12824 }
12825 | END_EVALUATE
12826 {
12827 TERMINATOR_CLEAR ($-2, EVALUATE);
12828 }
12829 ;
12830
12831 /* EXHIBIT statement */
12832
12833 exhibit_statement:
12834 EXHIBIT
12835 {
12836 begin_statement ("EXHIBIT", 0);
12837 line_column = NULL;
12838 cobc_cs_check = CB_CS_EXHIBIT;
12839 }
12840 exhibit_body
12841 {
12842 cobc_cs_check = 0;
12843 }
12844 ;
12845
12846 exhibit_body:
12847 _changed _named
12848 {
12849 if ($2 || !$1) {
12850 exhibit_named = 1;
12851 advancing_value = cb_int1;
12852 } else {
12853 exhibit_named = 0;
12854 }
12855 if ($1) {
12856 exhibit_changed = 1;
12857 /* TODO: feature for a later version (needs temporary fields,
12858 one per target, but not duplicated between multiple EXHIBIT) */
12859 CB_PENDING ("EXHIBIT CHANGED");
12860 /* note: literals are _always_ displayed, unchanged are replaced
12861 by spaces in full length (including the possible NAMED part) */
12862 } else {
12863 exhibit_changed = 0;
12864 }
12865 }
12866 _pos_specifier _erase exhibit_target_list _display_upon
12867 {
12868 /* note: position-specifier, ERASE and UPON are MS-COBOL extensions,
12869 but we won't add an extra dialect option for this - if wanted
12870 we can add one for the position-specifier and use that for
12871 those clauses, too */
12872 if (upon_value != NULL) {
12873 /* TODO: come back to this MS-COBOL feature later */
12874 CB_PENDING ("EXHIBIT UPON");
12875 }
12876 if ($5 != NULL) {
12877 attach_attrib_to_cur_stmt ();
12878 current_statement->attr_ptr->dispattrs = COB_SCREEN_ERASE_EOS;
12879 }
12880 /* note: while MF does not do this, OSVS had empty line suppression for
12881 CHANGED - do the same ... later */
12882 cb_emit_display ($6, NULL, cb_int1, line_column,
12883 current_statement->attr_ptr,
12884 0, DEVICE_DISPLAY);
12885 }
12886 ;
12887
12888 _changed: { $$ = NULL; } | CHANGED { $$ = cb_int0; } ;
12889 _named: { $$ = NULL; } | NAMED { $$ = cb_int0; } ;
12890
12891 exhibit_target_list:
12892 exhibit_target
12893 {
12894 if (exhibit_named && !CB_LITERAL_P ($1)) {
12895 $$ = CB_LIST_INIT (cb_exhbit_literal ($1));
12896 $$ = cb_list_add ($$, $1);
12897 } else {
12898 $$ = CB_LIST_INIT ($1);
12899 }
12900 }
12901 | exhibit_target_list exhibit_target
12902 {
12903 $$ = cb_list_add ($1, cb_space);
12904 if (exhibit_named && !CB_LITERAL_P ($2)) {
12905 $$ = cb_list_add ($$, cb_exhbit_literal ($2));
12906 }
12907 $$ = cb_list_add ($1, $2);
12908 }
12909 ;
12910
12911 exhibit_target:
12912 identifier
12913 | literal
12914 ;
12915
12916
12917 /* EXIT statement */
12918
12919 exit_statement:
12920 EXIT
12921 {
12922 begin_statement ("EXIT", 0);
12923 cobc_cs_check = CB_CS_EXIT;
12924 }
12925 exit_body
12926 {
12927 cobc_cs_check = 0;
12928 }
12929 ;
12930
12931 exit_body:
12932 /* empty */ %prec SHIFT_PREFER
12933 {
12934 /* TODO: add warning/error if there's another statement in the paragraph */
12935 }
12936 | PROGRAM exit_program_returning
12937 {
12938 if (in_declaratives && use_global_ind) {
12939 cb_error_x (CB_TREE (current_statement),
12940 _("EXIT PROGRAM is not allowed within a USE GLOBAL procedure"));
12941 }
12942 if (current_program->prog_type != COB_MODULE_TYPE_PROGRAM) {
12943 cb_error_x (CB_TREE (current_statement),
12944 _("EXIT PROGRAM not allowed within a FUNCTION"));
12945 }
12946 if (current_program->flag_main) {
12947 check_unreached = 0;
12948 } else {
12949 check_unreached = 1;
12950 }
12951 if ($2) {
12952 if (!current_program->cb_return_code) {
12953 cb_error_x ($2, _("RETURNING/GIVING not allowed for non-returning runtime elements"));
12954 } else {
12955 cb_emit_move ($2, CB_LIST_INIT (current_program->cb_return_code));
12956 }
12957 }
12958 current_statement->name = (const char *)"EXIT PROGRAM";
12959 cb_emit_exit (0);
12960 }
12961 | FUNCTION
12962 {
12963 if (in_declaratives && use_global_ind) {
12964 cb_error_x (CB_TREE (current_statement),
12965 _("EXIT FUNCTION is not allowed within a USE GLOBAL procedure"));
12966 }
12967 if (current_program->prog_type != COB_MODULE_TYPE_FUNCTION) {
12968 cb_error_x (CB_TREE (current_statement),
12969 _("EXIT FUNCTION only allowed within a FUNCTION"));
12970 }
12971 check_unreached = 1;
12972 current_statement->name = (const char *)"EXIT FUNCTION";
12973 cb_emit_exit (0);
12974 }
12975 | PERFORM CYCLE
12976 {
12977 struct cb_perform *p;
12978 cb_tree plabel;
12979 char name[64];
12980
12981 if (!perform_stack) {
12982 cb_error_x (CB_TREE (current_statement),
12983 _("EXIT PERFORM is only valid with inline PERFORM"));
12984 } else if (CB_VALUE (perform_stack) != cb_error_node) {
12985 p = CB_PERFORM (CB_VALUE (perform_stack));
12986 if (!p->cycle_label) {
12987 sprintf (name, "EXIT PERFORM CYCLE %d", cb_id);
12988 p->cycle_label = cb_build_reference (name);
12989 plabel = cb_build_label (p->cycle_label, NULL);
12990 CB_LABEL (plabel)->flag_begin = 1;
12991 CB_LABEL (plabel)->flag_dummy_exit = 1;
12992 }
12993 current_statement->name = (const char *)"EXIT PERFORM CYCLE";
12994 cb_emit_goto (CB_LIST_INIT (p->cycle_label), NULL);
12995 check_unreached = 1;
12996 }
12997 }
12998 | PERFORM
12999 {
13000 struct cb_perform *p;
13001 cb_tree plabel;
13002 char name[64];
13003
13004 if (!perform_stack) {
13005 cb_error_x (CB_TREE (current_statement),
13006 _("EXIT PERFORM is only valid with inline PERFORM"));
13007 } else if (CB_VALUE (perform_stack) != cb_error_node) {
13008 p = CB_PERFORM (CB_VALUE (perform_stack));
13009 if (!p->exit_label) {
13010 sprintf (name, "EXIT PERFORM %d", cb_id);
13011 p->exit_label = cb_build_reference (name);
13012 plabel = cb_build_label (p->exit_label, NULL);
13013 CB_LABEL (plabel)->flag_begin = 1;
13014 CB_LABEL (plabel)->flag_dummy_exit = 1;
13015 }
13016 current_statement->name = (const char *)"EXIT PERFORM";
13017 cb_emit_goto (CB_LIST_INIT (p->exit_label), NULL);
13018 check_unreached = 1;
13019 }
13020 }
13021 | SECTION
13022 {
13023 cb_tree plabel;
13024 char name[64];
13025
13026 if (!current_section) {
13027 cb_error_x (CB_TREE (current_statement),
13028 _("EXIT SECTION is only valid with an active SECTION"));
13029 } else {
13030 if (!current_section->exit_label) {
13031 sprintf (name, "EXIT SECTION %d", cb_id);
13032 current_section->exit_label = cb_build_reference (name);
13033 plabel = cb_build_label (current_section->exit_label, NULL);
13034 CB_LABEL (plabel)->flag_begin = 1;
13035 CB_LABEL (plabel)->flag_dummy_exit = 1;
13036 }
13037 current_statement->name = (const char *)"EXIT SECTION";
13038 cb_emit_goto (CB_LIST_INIT (current_section->exit_label), NULL);
13039 check_unreached = 1;
13040 }
13041 }
13042 | PARAGRAPH
13043 {
13044 cb_tree plabel;
13045 char name[64];
13046
13047 if (!current_paragraph) {
13048 cb_error_x (CB_TREE (current_statement),
13049 _("EXIT PARAGRAPH is only valid with an active PARAGRAPH"));
13050 } else {
13051 if (!current_paragraph->exit_label) {
13052 sprintf (name, "EXIT PARAGRAPH %d", cb_id);
13053 current_paragraph->exit_label = cb_build_reference (name);
13054 plabel = cb_build_label (current_paragraph->exit_label, NULL);
13055 CB_LABEL (plabel)->flag_begin = 1;
13056 CB_LABEL (plabel)->flag_dummy_exit = 1;
13057 }
13058 current_statement->name = (const char *)"EXIT PARAGRAPH";
13059 cb_emit_goto (CB_LIST_INIT (current_paragraph->exit_label), NULL);
13060 check_unreached = 1;
13061 }
13062 }
13063 ;
13064
13065 exit_program_returning:
13066 /* empty */ { $$ = NULL; }
13067 /* extension supported by MF and ACU
13068 (note: ACU supports this with x only, too) */
13069 | return_give x { $$ = $2; }
13070 ;
13071
13072
13073 /* FREE statement */
13074
13075 free_statement:
13076 FREE
13077 {
13078 begin_statement ("FREE", 0);
13079 current_statement->flag_no_based = 1;
13080 }
13081 free_body
13082 ;
13083
13084 free_body:
13085 target_x_list
13086 {
13087 cb_emit_free ($1);
13088 }
13089 ;
13090
13091
13092 /* GENERATE statement */
13093
13094 generate_statement:
13095 GENERATE
13096 {
13097 begin_statement ("GENERATE", 0);
13098 }
13099 generate_body
13100 ;
13101
13102
13103 generate_body:
13104 qualified_word
13105 {
13106 #if 0 /* CHECKME: likely not needed */
13107 begin_implicit_statement ();
13108 #endif
13109 if ($1 != cb_error_node) {
13110 cb_emit_generate ($1);
13111 }
13112 }
13113 ;
13114
13115 /* GO TO statement */
13116
13117 goto_statement:
13118 GO
13119 {
13120 if (!current_paragraph->flag_statement) {
13121 current_paragraph->flag_first_is_goto = 1;
13122 }
13123 begin_statement ("GO TO", 0);
13124 save_debug = start_debug;
13125 start_debug = 0;
13126 }
13127 go_body
13128 ;
13129
13130 go_body:
13131 _to procedure_name_list goto_depending
13132 {
13133 cb_emit_goto ($2, $3);
13134 start_debug = save_debug;
13135 }
13136 | _to ENTRY entry_name_list goto_depending
13137 {
13138 if (cb_verify (cb_goto_entry, "ENTRY FOR GO TO")) {
13139 cb_emit_goto_entry ($3, $4);
13140 }
13141 start_debug = save_debug;
13142 }
13143 ;
13144
13145 goto_depending:
13146 /* empty */
13147 {
13148 check_unreached = 1;
13149 $$ = NULL;
13150 }
13151 | DEPENDING _on identifier
13152 {
13153 check_unreached = 0;
13154 $$ = $3;
13155 }
13156 ;
13157
13158
13159 /* GOBACK statement */
13160
13161 goback_statement:
13162 GOBACK exit_program_returning
13163 {
13164 begin_statement ("GOBACK", 0);
13165 check_unreached = 1;
13166 if ($2) {
13167 if (!current_program->cb_return_code) {
13168 cb_error_x ($2, _("RETURNING/GIVING not allowed for non-returning runtime elements"));
13169 } else {
13170 cb_emit_move ($2, CB_LIST_INIT (current_program->cb_return_code));
13171 }
13172 }
13173 cb_emit_exit (1U);
13174 }
13175 ;
13176
13177
13178 /* IF statement */
13179
13180 if_statement:
13181 IF
13182 {
13183 begin_statement ("IF", TERM_IF);
13184 }
13185 condition _if_then if_else_statements
13186 _end_if
13187 ;
13188
13189 if_else_statements:
13190 if_true statement_list ELSE if_false statement_list
13191 {
13192 cb_emit_if ($-1, $2, $5);
13193 }
13194 | ELSE if_false statement_list
13195 {
13196 cb_emit_if ($-1, NULL, $3);
13197 cb_verify (cb_missing_statement,
13198 _("IF without imperative statement"));
13199 }
13200 | if_true statement_list %prec SHIFT_PREFER
13201 {
13202 cb_emit_if ($-1, $2, NULL);
13203 }
13204 ;
13205
13206 _if_then:
13207 {
13208 cb_save_cond ();
13209 }
13210 | THEN
13211 {
13212 cb_save_cond ();
13213 }
13214 ;
13215
13216 if_true:
13217 {
13218 cb_true_side ();
13219 }
13220 ;
13221
13222 if_false:
13223 {
13224 cb_false_side ();
13225 }
13226 ;
13227
13228 _end_if:
13229 /* empty */ %prec SHIFT_PREFER
13230 {
13231 TERMINATOR_WARNING ($-4, IF);
13232 cb_terminate_cond ();
13233 }
13234 | END_IF
13235 {
13236 TERMINATOR_CLEAR ($-4, IF);
13237 cb_terminate_cond ();
13238 }
13239 ;
13240
13241
13242 /* INITIALIZE statement */
13243
13244 initialize_statement:
13245 INITIALIZE
13246 {
13247 begin_statement ("INITIALIZE", 0);
13248 }
13249 initialize_body
13250 ;
13251
13252 initialize_body:
13253 target_x_list _initialize_filler _initialize_value
13254 _initialize_replacing _initialize_default
13255 {
13256 cb_emit_initialize ($1, $2, $3, $4, $5);
13257 }
13258 ;
13259
13260 _initialize_filler:
13261 /* empty */ { $$ = NULL; }
13262 | _with FILLER { $$ = cb_true; }
13263 ;
13264
13265 _initialize_value:
13266 /* empty */ { $$ = NULL; }
13267 | ALL _to VALUE { $$ = cb_true; }
13268 | initialize_category _to VALUE { $$ = $1; }
13269 ;
13270
13271 _initialize_replacing:
13272 /* empty */
13273 {
13274 $$ = NULL;
13275 }
13276 | REPLACING initialize_replacing_list
13277 {
13278 $$ = $2;
13279 }
13280 ;
13281
13282 initialize_replacing_list:
13283 initialize_replacing_item
13284 {
13285 $$ = $1;
13286 }
13287 | initialize_replacing_list
13288 initialize_replacing_item
13289 {
13290 $$ = cb_list_append ($1, $2);
13291 }
13292 ;
13293
13294 initialize_replacing_item:
13295 initialize_category _data BY x
13296 {
13297 $$ = CB_BUILD_PAIR ($1, $4);
13298 }
13299 ;
13300
13301 initialize_category:
13302 ALPHABETIC { $$ = cb_int (CB_CATEGORY_ALPHABETIC); }
13303 | ALPHANUMERIC { $$ = cb_int (CB_CATEGORY_ALPHANUMERIC); }
13304 | NUMERIC { $$ = cb_int (CB_CATEGORY_NUMERIC); }
13305 | ALPHANUMERIC_EDITED { $$ = cb_int (CB_CATEGORY_ALPHANUMERIC_EDITED); }
13306 | NUMERIC_EDITED { $$ = cb_int (CB_CATEGORY_NUMERIC_EDITED); }
13307 | NATIONAL { $$ = cb_int (CB_CATEGORY_NATIONAL); }
13308 | NATIONAL_EDITED { $$ = cb_int (CB_CATEGORY_NATIONAL_EDITED); }
13309 /* missing, needs test when added:
13310 | BOOLEAN { $$ = cb_int (CB_CATEGORY_BOOLEAN); }
13311 | DATA_POINTER { $$ = cb_int (CB_CATEGORY_DATA_POINTER); }
13312 | FUNCTION_POINTER { $$ = cb_int (CB_CATEGORY_FUNCTION_POINTER); }
13313 | PROGRAM_POINTER { $$ = cb_int (CB_CATEGORY_PROGRAM_POINTER); }
13314 | OBJECT_REFERENCE { $$ = cb_int (CB_CATEGORY_OBJECT_REFERENCE); }
13315 */
13316 ;
13317
13318 _initialize_default:
13319 /* empty */
13320 {
13321 $$ = NULL;
13322 }
13323 | _then _to DEFAULT
13324 {
13325 $$ = cb_true;
13326 }
13327 ;
13328
13329 /* INITIATE statement */
13330
13331 initiate_statement:
13332 INITIATE
13333 {
13334 begin_statement ("INITIATE", 0);
13335 }
13336 initiate_body
13337 ;
13338
13339 initiate_body:
13340 report_name
13341 {
13342 #if 0 /* CHECKME: likely not needed */
13343 begin_implicit_statement ();
13344 #endif
13345 if ($1 != cb_error_node) {
13346 cb_emit_initiate ($1);
13347 }
13348 }
13349 | initiate_body report_name
13350 {
13351 begin_implicit_statement ();
13352 if ($2 != cb_error_node) {
13353 cb_emit_initiate ($2);
13354 }
13355 }
13356 ;
13357
13358 /* INQUIRE statement */
13359
13360 inquire_statement:
13361 INQUIRE
13362 {
13363 begin_statement ("INQUIRE", 0);
13364 cobc_cs_check = CB_CS_INQUIRE_MODIFY;
13365 }
13366 inquire_body
13367 {
13368 cobc_cs_check = 0;
13369 }
13370 ;
13371
13372 inquire_body:
13373 control_item changeable_control_properties
13374 | window_handle changeable_window_properties
13375 ;
13376
13377 /* INSPECT statement */
13378
13379 inspect_statement:
13380 INSPECT
13381 {
13382 begin_statement ("INSPECT", 0);
13383 inspect_keyword = 0;
13384 }
13385 inspect_body
13386 ;
13387
13388 inspect_body:
13389 send_identifier inspect_list
13390 ;
13391
13392 send_identifier:
13393 identifier
13394 | literal
13395 | function
13396 ;
13397
13398 inspect_list:
13399 inspect_tallying inspect_replacing
13400 | inspect_tallying
13401 | inspect_replacing
13402 | inspect_converting
13403 ;
13404
13405 /* INSPECT TALLYING */
13406
13407 inspect_tallying:
13408 TALLYING
13409 {
13410 previous_tallying_phrase = NO_PHRASE;
13411 cb_init_tallying ();
13412 }
13413 tallying_list
13414 {
13415 if (!(previous_tallying_phrase == CHARACTERS_PHRASE
13416 || previous_tallying_phrase == VALUE_REGION_PHRASE)) {
13417 cb_error (_("TALLYING clause is incomplete"));
13418 } else {
13419 cb_emit_inspect ($0, $3, TALLYING_CLAUSE);
13420 }
13421
13422 $$ = $0;
13423 }
13424 ;
13425
13426 /* INSPECT REPLACING */
13427
13428 inspect_replacing:
13429 REPLACING replacing_list
13430 {
13431 cb_emit_inspect ($0, $2, REPLACING_CLAUSE);
13432 inspect_keyword = 0;
13433 }
13434 ;
13435
13436 /* INSPECT CONVERTING */
13437
13438 inspect_converting:
13439 CONVERTING inspect_from TO inspect_to inspect_region
13440 {
13441 cb_tree x = cb_build_converting ($2, $4, $5);
13442 cb_emit_inspect ($0, x, CONVERTING_CLAUSE);
13443 }
13444 ;
13445
13446 tallying_list:
13447 tallying_item
13448 {
13449 $$ = $1;
13450 }
13451 | tallying_list tallying_item
13452 {
13453 $$ = cb_list_append ($1, $2);
13454 }
13455 ;
13456
13457 tallying_item:
13458 numeric_identifier FOR
13459 {
13460 check_preceding_tallying_phrases (FOR_PHRASE);
13461 $$ = cb_build_tallying_data ($1);
13462 }
13463 | CHARACTERS inspect_region
13464 {
13465 check_preceding_tallying_phrases (CHARACTERS_PHRASE);
13466 $$ = cb_build_tallying_characters ($2);
13467 }
13468 | ALL
13469 {
13470 check_preceding_tallying_phrases (ALL_LEADING_TRAILING_PHRASES);
13471 $$ = cb_build_tallying_all ();
13472 }
13473 | LEADING
13474 {
13475 check_preceding_tallying_phrases (ALL_LEADING_TRAILING_PHRASES);
13476 $$ = cb_build_tallying_leading ();
13477 }
13478 | TRAILING
13479 {
13480 check_preceding_tallying_phrases (ALL_LEADING_TRAILING_PHRASES);
13481 $$ = cb_build_tallying_trailing ();
13482 }
13483 | simple_display_value inspect_region
13484 {
13485 check_preceding_tallying_phrases (VALUE_REGION_PHRASE);
13486 $$ = cb_build_tallying_value ($1, $2);
13487 }
13488 ;
13489
13490 replacing_list:
13491 replacing_item { $$ = $1; }
13492 | replacing_list replacing_item { $$ = cb_list_append ($1, $2); }
13493 ;
13494
13495 replacing_item:
13496 CHARACTERS BY simple_display_value inspect_region
13497 {
13498 $$ = cb_build_replacing_characters ($3, $4);
13499 inspect_keyword = 0;
13500 }
13501 | rep_keyword replacing_region
13502 {
13503 $$ = $2;
13504 }
13505 ;
13506
13507 rep_keyword:
13508 /* empty */
13509 | ALL { inspect_keyword = 1; }
13510 | LEADING { inspect_keyword = 2; }
13511 | FIRST { inspect_keyword = 3; }
13512 | TRAILING { inspect_keyword = 4; }
13513 ;
13514
13515 replacing_region:
13516 inspect_from BY inspect_to inspect_region
13517 {
13518 switch (inspect_keyword) {
13519 case 1:
13520 $$ = cb_build_replacing_all ($1, $3, $4);
13521 break;
13522 case 2:
13523 $$ = cb_build_replacing_leading ($1, $3, $4);
13524 break;
13525 case 3:
13526 $$ = cb_build_replacing_first ($1, $3, $4);
13527 break;
13528 case 4:
13529 $$ = cb_build_replacing_trailing ($1, $3, $4);
13530 break;
13531 default:
13532 cb_error_x (CB_TREE (current_statement),
13533 _("INSPECT missing ALL/FIRST/LEADING/TRAILING"));
13534 $$ = cb_build_replacing_all ($1, $3, $4);
13535 break;
13536 }
13537 }
13538 ;
13539
13540 /* INSPECT BEFORE/AFTER */
13541
13542 inspect_region:
13543 /* empty */
13544 {
13545 $$ = cb_build_inspect_region_start ();
13546 }
13547 | inspect_before
13548 {
13549 $$ = cb_list_add (cb_build_inspect_region_start (), $1);
13550 }
13551 | inspect_after
13552 {
13553 $$ = cb_list_add (cb_build_inspect_region_start (), $1);
13554 }
13555 | inspect_before inspect_after
13556 {
13557 $$ = cb_list_add (cb_list_add (cb_build_inspect_region_start (), $1), $2);
13558 }
13559 | inspect_after inspect_before
13560 {
13561 $$ = cb_list_add (cb_list_add (cb_build_inspect_region_start (), $1), $2);
13562 }
13563 ;
13564
13565 inspect_before:
13566 BEFORE _initial x
13567 {
13568 $$ = CB_BUILD_FUNCALL_1 ("cob_inspect_before", $3);
13569 }
13570 ;
13571
13572 inspect_after:
13573 AFTER _initial x
13574 {
13575 $$ = CB_BUILD_FUNCALL_1 ("cob_inspect_after", $3);
13576 }
13577 ;
13578
13579 /* JSON GENERATE statement */
13580
13581 json_generate_statement:
13582 JSON GENERATE
13583 {
13584 begin_statement ("JSON GENERATE", TERM_JSON);
13585 cobc_in_json_generate_body = 1;
13586 cobc_cs_check = CB_CS_JSON_GENERATE;
13587 }
13588 json_generate_body
13589 _end_json
13590 ;
13591
13592 json_generate_body:
13593 identifier FROM identifier
13594 _count_in
13595 {
13596 ml_suppress_list = NULL;
13597 }
13598 _json_name_of
13599 _json_suppress
13600 {
13601 cobc_in_json_generate_body = 0;
13602 cobc_cs_check = 0;
13603 }
13604 _json_exception_phrases
13605 {
13606 cb_emit_json_generate ($1, $3, $4, $6, ml_suppress_list);
13607 }
13608 ;
13609
13610 _json_suppress:
13611 /* empty */
13612 {
13613 $$ = NULL;
13614 }
13615 | SUPPRESS_XML json_suppress_list
13616 {
13617 $$ = $2;
13618 }
13619 ;
13620
13621 json_suppress_list:
13622 json_suppress_entry
13623 | json_suppress_list json_suppress_entry
13624 ;
13625
13626 json_suppress_entry:
13627 identifier
13628 {
13629 error_if_following_every_clause ();
13630 add_identifier_to_ml_suppress_conds ($1);
13631 }
13632 ;
13633
13634 _end_json:
13635 /* empty */ %prec SHIFT_PREFER
13636 {
13637 TERMINATOR_WARNING ($-2, JSON);
13638 }
13639 | END_JSON
13640 {
13641 TERMINATOR_CLEAR ($-2, JSON);
13642 }
13643 ;
13644
13645 /* JSON PARSE statement */
13646
13647 json_parse_statement:
13648 JSON PARSE
13649 {
13650 begin_statement ("JSON PARSE", TERM_JSON);
13651 CB_PENDING (_("JSON PARSE"));
13652 }
13653 json_parse_body
13654 _end_json
13655 ;
13656
13657 json_parse_body:
13658 identifier INTO identifier
13659 _with_detail
13660 _json_name_of
13661 _json_suppress
13662 _json_exception_phrases
13663 ;
13664
13665 _with_detail:
13666 /* empty */
13667 | _with DETAIL
13668 ;
13669
13670 /* MERGE statement */
13671
13672 merge_statement:
13673 MERGE
13674 {
13675 begin_statement ("MERGE", 0);
13676 current_statement->flag_merge = 1;
13677 }
13678 sort_body
13679 ;
13680
13681
13682 /* MODIFY statement */
13683
13684 modify_statement:
13685 MODIFY
13686 {
13687 begin_statement ("MODIFY", TERM_MODIFY);
13688 cobc_cs_check = CB_CS_INQUIRE_MODIFY;
13689 }
13690 modify_body
13691 _end_modify
13692 {
13693 cobc_cs_check = 0;
13694 }
13695 ;
13696
13697 modify_body:
13698 control_item control_attributes
13699 | window_handle changeable_window_properties
13700 ;
13701
13702 _end_modify:
13703 /* empty */ %prec SHIFT_PREFER
13704 {
13705 TERMINATOR_WARNING ($-2, MODIFY);
13706 }
13707 | END_MODIFY
13708 {
13709 TERMINATOR_CLEAR ($-2, MODIFY);
13710 }
13711 ;
13712
13713
13714 /* MOVE statement */
13715
13716 move_statement:
13717 MOVE
13718 {
13719 begin_statement ("MOVE", 0);
13720 }
13721 move_body
13722 ;
13723
13724 move_body:
13725 x TO target_x_list
13726 {
13727 cb_emit_move ($1, $3);
13728 }
13729 | CORRESPONDING x TO target_x_list
13730 {
13731 cb_emit_move_corresponding ($2, $4);
13732 }
13733 ;
13734
13735
13736 /* MULTIPLY statement */
13737
13738 multiply_statement:
13739 MULTIPLY
13740 {
13741 begin_statement ("MULTIPLY", TERM_MULTIPLY);
13742 }
13743 multiply_body
13744 _end_multiply
13745 ;
13746
13747 multiply_body:
13748 x BY arithmetic_x_list on_size_error_phrases
13749 {
13750 cb_emit_arithmetic ($3, '*', $1);
13751 }
13752 | x BY x GIVING arithmetic_x_list on_size_error_phrases
13753 {
13754 cb_emit_arithmetic ($5, 0, cb_build_binary_op ($1, '*', $3));
13755 }
13756 ;
13757
13758 _end_multiply:
13759 /* empty */ %prec SHIFT_PREFER
13760 {
13761 TERMINATOR_WARNING ($-2, MULTIPLY);
13762 }
13763 | END_MULTIPLY
13764 {
13765 TERMINATOR_CLEAR ($-2, MULTIPLY);
13766 }
13767 ;
13768
13769
13770 /* OPEN statement */
13771
13772 open_statement:
13773 OPEN
13774 {
13775 begin_statement ("OPEN", 0);
13776 cobc_cs_check = CB_CS_OPEN;
13777 }
13778 open_body
13779 ;
13780
13781 open_body:
13782 open_file_entry
13783 | open_body open_file_entry
13784 ;
13785
13786 open_file_entry:
13787 _open_exclusive open_mode _open_sharing _retry_phrase file_name_list _open_option
13788 {
13789 cb_tree l;
13790 cb_tree x;
13791
13792 if (($1 && $3) || ($1 && $6) || ($3 && $6)) {
13793 cb_error_x (CB_TREE (current_statement),
13794 _("%s and %s are mutually exclusive"), "SHARING", _("LOCK clauses"));
13795 }
13796 if ($6) {
13797 x = $6;
13798 } else if ($3) {
13799 x = $3;
13800 } else {
13801 x = $1;
13802 }
13803
13804 for (l = $5; l; l = CB_CHAIN (l)) {
13805 if (CB_VALID_TREE (CB_VALUE (l))) {
13806 begin_implicit_statement ();
13807 cb_emit_open (CB_VALUE (l), $2, x);
13808 }
13809 }
13810 }
13811 ;
13812
13813 /* RM/COBOL extension */
13814 _open_exclusive:
13815 /* empty */ { $$ = NULL; }
13816 | EXCLUSIVE { $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE); }
13817 ;
13818
13819 open_mode:
13820 INPUT { $$ = cb_int (COB_OPEN_INPUT); }
13821 | OUTPUT { $$ = cb_int (COB_OPEN_OUTPUT); }
13822 | I_O { $$ = cb_int (COB_OPEN_I_O); }
13823 | EXTEND { $$ = cb_int (COB_OPEN_EXTEND); }
13824 ;
13825
13826 _open_sharing:
13827 /* empty */ { $$ = NULL; }
13828 | SHARING _with sharing_option { $$ = $3; }
13829 ;
13830
13831 _open_option:
13832 /* empty */ { $$ = NULL; }
13833 | lock_allowing { $$ = $1; }
13834 | open_option_sequential { $$ = NULL; }
13835 /* note: RM/COBOL allow lock together with the other options,
13836 most (all?) other dialects allow only one of them
13837 extra rule to possibly cater for this later */
13838 | lock_allowing open_option_sequential { $$ = $1; }
13839 | osvs_input_mode
13840 {
13841 (void)cb_verify (CB_OBSOLETE, "OPEN LEAVE/REREAD/DISP");
13842 $$ = NULL;
13843 }
13844 ;
13845
13846 lock_allowing:
13847 _with_for open_lock_option { $$ = $2; }
13848 | ALLOWING allowing_option { $$ = $2; }
13849 ;
13850
13851 open_lock_option:
13852 LOCK { $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE); }
13853 | MASS_UPDATE
13854 {
13855 $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE);
13856 /* TODO: check for indexed; pass extra flag to fileio */
13857 CB_PENDING ("WITH MASS-UPDATE");
13858 }
13859 | BULK_ADDITION
13860 {
13861 $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE);
13862 /* TODO: check for indexed; pass extra flag to fileio */
13863 CB_PENDING ("WITH BULK-ADDITION");
13864 }
13865 ;
13866
13867 allowing_option:
13868 NO _others { $$ = cb_int (COB_LOCK_OPEN_EXCLUSIVE); }
13869 | allowing_all { $$ = NULL; }
13870 | READERS { $$ = NULL; } /* docs say: identical to EXCLUSIVE + OPEN INPUT, CHECKME */
13871 ;
13872
13873 /* strange, but according to ACUCOBOL docs they are all identical */
13874 allowing_all:
13875 WRITERS
13876 | UPDATERS
13877 | ALL
13878 ;
13879
13880 open_option_sequential:
13881 _with NO REWIND
13882 {
13883 /* FIXME: only allow for sequential files */
13884 /* FIXME: only allow with INPUT or OUTPUT */
13885 CB_PENDING ("OPEN WITH NO REWIND");
13886 $$ = NULL;
13887 }
13888 | REVERSED
13889 {
13890 /* FIXME: only allow for sequential / line-sequential files */
13891 /* FIXME: only allow with INPUT */
13892 /* FIXME: add actual compiler configuration */
13893 if (cb_warn_opt_val[cb_warn_obsolete] == COBC_WARN_AS_ERROR) {
13894 (void)cb_verify (CB_OBSOLETE, "OPEN REVERSED");
13895 } else {
13896 /* FIXME: set file attribute */
13897 CB_PENDING ("OPEN REVERSED");
13898 };
13899 $$ = NULL;
13900 }
13901 ;
13902
13903 osvs_input_mode:
13904 LEAVE
13905 | REREAD
13906 | DISP;
13907
13908 /* PERFORM statement */
13909
13910 perform_statement:
13911 PERFORM
13912 {
13913 begin_statement ("PERFORM", TERM_PERFORM);
13914 /* Turn off field debug - PERFORM is special */
13915 save_debug = start_debug;
13916 start_debug = 0;
13917 cobc_cs_check = CB_CS_PERFORM;
13918 }
13919 perform_body
13920 ;
13921
13922 perform_body:
13923 _thread_start
13924 perform_procedure
13925 _thread_handle
13926 _perform_option
13927 {
13928 cb_emit_perform ($4, $2, $1, $3);
13929 start_debug = save_debug;
13930 cobc_cs_check = 0;
13931 }
13932 | _thread_start
13933 _perform_option
13934 _thread_handle
13935 {
13936 CB_ADD_TO_CHAIN ($2, perform_stack);
13937 /* Restore field debug before inline statements */
13938 start_debug = save_debug;
13939 cobc_cs_check = 0;
13940 }
13941 statement_list _end_perform
13942 {
13943 perform_stack = CB_CHAIN (perform_stack);
13944 cb_emit_perform ($2, $5, $1, $3);
13945 }
13946 | _thread_start
13947 _perform_option
13948 _thread_handle
13949 {
13950 cb_verify (cb_missing_statement,
13951 _("inline PERFORM without imperative statement"));
13952 }
13953 end_perform_or_dot
13954 {
13955 cb_emit_perform ($2, NULL, $1, $3);
13956 start_debug = save_debug;
13957 cobc_cs_check = 0;
13958 }
13959 ;
13960
13961 _end_perform:
13962 /* empty */ %prec SHIFT_PREFER
13963 {
13964 if (cb_relaxed_syntax_checks) {
13965 TERMINATOR_WARNING ($-6, PERFORM);
13966 } else {
13967 TERMINATOR_ERROR ($-6, PERFORM);
13968 }
13969 }
13970 | END_PERFORM
13971 {
13972 TERMINATOR_CLEAR ($-6, PERFORM);
13973 }
13974 ;
13975
13976 end_perform_or_dot:
13977 END_PERFORM
13978 {
13979 TERMINATOR_CLEAR ($-3, PERFORM);
13980 }
13981 | TOK_DOT
13982 {
13983 if (cb_relaxed_syntax_checks) {
13984 TERMINATOR_WARNING ($-3, PERFORM);
13985 } else {
13986 TERMINATOR_ERROR ($-3, PERFORM);
13987 }
13988 /* Put the dot token back into the stack for reparse */
13989 cb_unput_dot ();
13990 }
13991 ;
13992
13993 perform_procedure:
13994 procedure_name
13995 {
13996 /* Return from $1 */
13997 CB_REFERENCE ($1)->length = cb_true;
13998 CB_REFERENCE ($1)->flag_decl_ok = 1;
13999 $$ = CB_BUILD_PAIR ($1, $1);
14000 }
14001 | procedure_name THRU procedure_name
14002 {
14003 /* Return from $3 */
14004 CB_REFERENCE ($3)->length = cb_true;
14005 CB_REFERENCE ($1)->flag_decl_ok = 1;
14006 CB_REFERENCE ($3)->flag_decl_ok = 1;
14007 $$ = CB_BUILD_PAIR ($1, $3);
14008 }
14009 ;
14010
14011 _perform_option:
14012 /* empty */
14013 {
14014 $$ = cb_build_perform_once (NULL);
14015 }
14016 | id_or_lit_or_length_or_func TIMES
14017 {
14018 $$ = cb_build_perform_times ($1);
14019 current_program->loop_counter++;
14020 }
14021 | FOREVER
14022 {
14023 $$ = cb_build_perform_forever (NULL);
14024 }
14025 | perform_test UNTIL cond_or_exit
14026 {
14027 cb_tree varying;
14028
14029 if (!$3) {
14030 $$ = cb_build_perform_forever (NULL);
14031 } else {
14032 if ($1 == CB_AFTER)
14033 cb_build_perform_after_until();
14034 varying = CB_LIST_INIT (cb_build_perform_varying (NULL, NULL, NULL, $3));
14035 $$ = cb_build_perform_until ($1, varying);
14036 }
14037 }
14038 | perform_test VARYING perform_varying_list
14039 {
14040 $$ = cb_build_perform_until ($1, $3);
14041 }
14042 ;
14043
14044 perform_test:
14045 /* empty */ { $$ = CB_BEFORE; }
14046 | _with TEST before_or_after { $$ = $3; }
14047 ;
14048
14049 cond_or_exit:
14050 EXIT { $$ = NULL; }
14051 | condition { $$ = $1; }
14052
14053 perform_varying_list:
14054 perform_varying { $$ = CB_LIST_INIT ($1); }
14055 | perform_varying_list AFTER
14056 perform_varying { $$ = cb_list_add ($1, $3); }
14057 ;
14058
14059 perform_varying:
14060 identifier FROM x _by_phrase UNTIL condition
14061 {
14062 cb_tree x;
14063 int data_type_ok = 1;
14064
14065 if ($1 != cb_error_node
14066 && $3 != cb_error_node
14067 && $4 != cb_error_node) {
14068
14069 if (cb_tree_category ($1) != CB_CATEGORY_NUMERIC) {
14070 x = cb_ref ($1);
14071 cb_error_x (CB_TREE (current_statement),
14072 _("PERFORM VARYING '%s' (line %d of %s) is not a numeric field"),
14073 cb_name (x),x->source_line, x->source_file);
14074 $$ = cb_int1;
14075 data_type_ok = 0;
14076 }
14077 if (cb_tree_category ($3) != CB_CATEGORY_NUMERIC) {
14078 x = cb_ref ($3);
14079 cb_error_x (CB_TREE (current_statement),
14080 _("PERFORM VARYING '%s' (line %d of %s) is not a numeric field"),
14081 cb_name (x),x->source_line, x->source_file);
14082 $$ = cb_int1;
14083 data_type_ok = 0;
14084 }
14085 if (cb_tree_category ($4) != CB_CATEGORY_NUMERIC) {
14086 x = cb_ref ($4);
14087 cb_error_x (CB_TREE (current_statement),
14088 _("PERFORM VARYING '%s' (line %d of %s) is not a numeric field"),
14089 cb_name (x),x->source_line, x->source_file);
14090 $$ = cb_int1;
14091 data_type_ok = 0;
14092 }
14093
14094 if (data_type_ok) {
14095 $$ = cb_build_perform_varying ($1, $3, $4, $6);
14096 }
14097 }
14098 }
14099 ;
14100
14101 _by_phrase:
14102 /*empty */
14103 {
14104 cb_verify (cb_perform_varying_without_by, _("PERFORM VARYING without BY phrase"));
14105 $$ = cb_build_numeric_literal (0, "1", 0);
14106 }
14107 | BY arith_nonzero_x
14108 {
14109 $$ = $2;
14110 }
14111 ;
14112
14113 /* PURGE statement (COMMUNICATION SECTION) */
14114
14115 purge_statement:
14116 PURGE
14117 {
14118 begin_statement ("PURGE", 0);
14119 }
14120 cd_name
14121 {
14122 }
14123 ;
14124
14125 /* RAISE statement */
14126
14127 raise_statement:
14128 RAISE
14129 {
14130 begin_statement ("RAISE", 0);
14131 }
14132 raise_body
14133 ;
14134
14135 raise_body:
14136 EXCEPTION exception_name
14137 {
14138 CB_PENDING ("RAISE statement");
14139 /* TODO: check for level 3 error here */
14140 }
14141 | identifier
14142 {
14143 /* easy cheating here as we don't have any OO in */
14144 cb_error(_("'%s' is not an object-reference"), cb_name ($1));
14145 }
14146 ;
14147
14148
14149
14150 exception_name:
14151 WORD
14152 {
14153 /* TODO:
14154 cb_tree exception = get_exception (CB_NAME($1));
14155 if (!exception) {
14156 cb_error (_("'%s' is not an exception-name"), CB_NAME ($1));
14157 }
14158 */
14159 }
14160 ;
14161
14162 /* READ statement */
14163
14164 read_statement:
14165 READ
14166 {
14167 begin_statement ("READ", TERM_READ);
14168 cobc_cs_check = CB_CS_READ;
14169 }
14170 read_body
14171 _end_read
14172 ;
14173
14174 read_body:
14175 file_name _flag_next _record _read_into _lock_phrases _read_key read_handler
14176 {
14177 cobc_cs_check = 0;
14178
14179 if (CB_VALID_TREE ($1)) {
14180 struct cb_file *cf;
14181
14182 cf = CB_FILE(cb_ref ($1));
14183 if ($5 && (cf->lock_mode & COB_LOCK_AUTOMATIC)) {
14184 cb_error_x (CB_TREE (current_statement),
14185 _("LOCK clause invalid with file LOCK AUTOMATIC"));
14186 } else if ($6 &&
14187 (cf->organization != COB_ORG_RELATIVE &&
14188 cf->organization != COB_ORG_INDEXED)) {
14189 cb_error_x (CB_TREE (current_statement),
14190 _("KEY clause invalid with this file type"));
14191 } else if (current_statement->handler_type == INVALID_KEY_HANDLER &&
14192 (cf->organization != COB_ORG_RELATIVE &&
14193 cf->organization != COB_ORG_INDEXED)) {
14194 cb_error_x (CB_TREE (current_statement),
14195 _("INVALID KEY clause invalid with this file type"));
14196 } else {
14197 cb_emit_read ($1, $2, $4, $6, $5);
14198 }
14199 }
14200 }
14201 ;
14202
14203 _read_into:
14204 /* empty */ { $$ = NULL; }
14205 | INTO identifier { $$ = $2; }
14206 ;
14207
14208 _lock_phrases:
14209 /* empty */ %prec SHIFT_PREFER
14210 {
14211 $$ = NULL;
14212 }
14213 | ignoring_lock
14214 {
14215 $$ = cb_int3;
14216 }
14217 | advancing_lock_or_retry _extended_with_lock
14218 {
14219 $$ = $2;
14220 }
14221 | extended_with_lock
14222 {
14223 $$ = $1;
14224 }
14225 ;
14226
14227 ignoring_lock:
14228 IGNORING LOCK
14229 | _with IGNORE LOCK
14230 ;
14231
14232 advancing_lock_or_retry:
14233 ADVANCING _on LOCK
14234 {
14235 CB_PENDING ("ADVANCING ON LOCK");
14236 }
14237 | retry_phrase
14238 ;
14239
14240 _retry_phrase:
14241 /* empty */
14242 | retry_phrase
14243 ;
14244
14245 retry_phrase:
14246 retry_options
14247 {
14248 CB_PENDING ("RETRY");
14249 cobc_cs_check = 0;
14250 }
14251 ;
14252
14253 retry_options:
14254 /* HACK: added _for to fix shift/reduce conflict. */
14255 RETRY _for exp TIMES
14256 | RETRY _for exp SECONDS
14257 | RETRY FOREVER
14258 ;
14259
14260 _extended_with_lock:
14261 /* empty */
14262 | extended_with_lock
14263 ;
14264
14265 extended_with_lock:
14266 with_lock
14267 {
14268 $$ = $1;
14269 }
14270 | _with KEPT LOCK
14271 {
14272 $$ = cb_int5;
14273 }
14274 | _with WAIT
14275 {
14276 /* TO-DO: Merge with RETRY phrase */
14277 $$ = cb_int4;
14278 }
14279 ;
14280
14281 _read_key:
14282 /* empty */ { $$ = NULL; }
14283 | KEY _is identifier { $$ = $3; }
14284 ;
14285
14286 read_handler:
14287 _invalid_key_phrases
14288 | at_end
14289 ;
14290
14291 _end_read:
14292 /* empty */ %prec SHIFT_PREFER
14293 {
14294 TERMINATOR_WARNING ($-2, READ);
14295 }
14296 | END_READ
14297 {
14298 TERMINATOR_CLEAR ($-2, READ);
14299 }
14300 ;
14301
14302
14303 /* READY TRACE statement */
14304
14305 ready_statement:
14306 READY_TRACE
14307 {
14308 begin_statement ("READY TRACE", 0);
14309 cb_emit_ready_trace ();
14310 }
14311 ;
14312
14313 /* RECEIVE statement (COMMUNICATION) */
14314
14315 receive_statement:
14316 RECEIVE
14317 {
14318 begin_statement ("RECEIVE", TERM_RECEIVE);
14319 }
14320 receive_body
14321 _end_receive
14322 ;
14323
14324 receive_body:
14325 cd_name message_or_segment INTO identifier
14326 _data_sentence_phrases
14327 ;
14328
14329 message_or_segment:
14330 MESSAGE
14331 | SEGMENT
14332 ;
14333
14334 _data_sentence_phrases:
14335 /* empty */ %prec SHIFT_PREFER
14336 | no_data_sentence _with_data_sentence
14337 | with_data_sentence _no_data_sentence
14338 ;
14339
14340 _no_data_sentence:
14341 /* empty */ %prec SHIFT_PREFER
14342 | no_data_sentence
14343 ;
14344
14345 no_data_sentence:
14346 NO_DATA statement_list
14347 ;
14348
14349 _with_data_sentence:
14350 /* empty */ %prec SHIFT_PREFER
14351 | with_data_sentence
14352 ;
14353
14354 with_data_sentence:
14355 DATA statement_list /* Optional WITH matched in scanner.l */
14356 ;
14357
14358 _end_receive:
14359 /* empty */ %prec SHIFT_PREFER
14360 {
14361 TERMINATOR_WARNING ($-2, RECEIVE);
14362 }
14363 | END_RECEIVE
14364 {
14365 TERMINATOR_CLEAR ($-2, RECEIVE);
14366 }
14367 ;
14368
14369 /* RELEASE statement */
14370
14371 release_statement:
14372 RELEASE
14373 {
14374 begin_statement ("RELEASE", 0);
14375 }
14376 release_body
14377 ;
14378
14379 release_body:
14380 record_name from_option
14381 {
14382 cb_emit_release ($1, $2);
14383 }
14384 ;
14385
14386
14387 /* RESET TRACE statement */
14388
14389 reset_statement:
14390 RESET_TRACE
14391 {
14392 begin_statement ("RESET TRACE", 0);
14393 cb_emit_reset_trace ();
14394 }
14395 ;
14396
14397 /* RETURN statement */
14398
14399 return_statement:
14400 RETURN
14401 {
14402 begin_statement ("RETURN", TERM_RETURN);
14403 }
14404 return_body
14405 _end_return
14406 ;
14407
14408 return_body:
14409 file_name _record _read_into return_at_end
14410 {
14411 cb_emit_return ($1, $3);
14412 }
14413 ;
14414
14415 _end_return:
14416 /* empty */ %prec SHIFT_PREFER
14417 {
14418 TERMINATOR_WARNING ($-2, RETURN);
14419 }
14420 | END_RETURN
14421 {
14422 TERMINATOR_CLEAR ($-2, RETURN);
14423 }
14424 ;
14425
14426
14427 /* REWRITE statement */
14428
14429 rewrite_statement:
14430 REWRITE
14431 {
14432 begin_statement ("REWRITE", TERM_REWRITE);
14433 /* Special in debugging mode */
14434 save_debug = start_debug;
14435 start_debug = 0;
14436 }
14437 rewrite_body
14438 _end_rewrite
14439 ;
14440
14441 rewrite_body:
14442 file_or_record_name from_option _retry_phrase _with_lock _invalid_key_phrases
14443 {
14444 cb_emit_rewrite ($1, $2, $4);
14445 start_debug = save_debug;
14446 }
14447 ;
14448
14449 _with_lock:
14450 /* empty */
14451 {
14452 $$ = NULL;
14453 }
14454 | with_lock
14455 ;
14456
14457 with_lock:
14458 _with LOCK
14459 {
14460 $$ = cb_int1;
14461 }
14462 | _with NO LOCK
14463 {
14464 $$ = cb_int2;
14465 }
14466 ;
14467
14468 _end_rewrite:
14469 /* empty */ %prec SHIFT_PREFER
14470 {
14471 TERMINATOR_WARNING ($-2, REWRITE);
14472 }
14473 | END_REWRITE
14474 {
14475 TERMINATOR_CLEAR ($-2, REWRITE);
14476 }
14477 ;
14478
14479
14480 /* ROLLBACK statement */
14481
14482 rollback_statement:
14483 ROLLBACK
14484 {
14485 begin_statement ("ROLLBACK", 0);
14486 cb_emit_rollback ();
14487 }
14488 ;
14489
14490
14491 /* SEARCH statement */
14492
14493 search_statement:
14494 SEARCH
14495 {
14496 begin_statement ("SEARCH", TERM_SEARCH);
14497 }
14498 search_body
14499 _end_search
14500 ;
14501
14502 search_body:
14503 table_name search_varying search_at_end search_whens
14504 {
14505 cb_emit_search ($1, $2, $3, $4);
14506 }
14507 | ALL table_name search_at_end WHEN expr
14508 statement_list
14509 {
14510 current_statement->name = (const char *)"SEARCH ALL";
14511 cb_emit_search_all ($2, $3, $5, $6);
14512 }
14513 ;
14514
14515 search_varying:
14516 /* empty */ { $$ = NULL; }
14517 | VARYING identifier { $$ = $2; }
14518 ;
14519
14520 search_at_end:
14521 /* empty */
14522 {
14523 $$ = NULL;
14524 }
14525 | END
14526 statement_list
14527 {
14528 $$ = $2;
14529 }
14530 ;
14531
14532 search_whens:
14533 search_when %prec SHIFT_PREFER
14534 {
14535 $$ = CB_LIST_INIT ($1);
14536 }
14537 | search_when search_whens
14538 {
14539 $$ = cb_list_add ($2, $1);
14540 }
14541 ;
14542
14543 search_when:
14544 WHEN condition
14545 statement_list
14546 {
14547 $$ = cb_build_if_check_break ($2, $3);
14548 }
14549 ;
14550
14551 _end_search:
14552 /* empty */ %prec SHIFT_PREFER
14553 {
14554 TERMINATOR_WARNING ($-2, SEARCH);
14555 }
14556 | END_SEARCH
14557 {
14558 TERMINATOR_CLEAR ($-2, SEARCH);
14559 }
14560 ;
14561
14562
14563 /* SEND statement (COMMUNICATION SECTION) */
14564
14565 send_statement:
14566 SEND
14567 {
14568 begin_statement ("SEND", 0);
14569 }
14570 send_body
14571 ;
14572
14573 send_body:
14574 cd_name from_identifier
14575 {
14576 }
14577 | cd_name _from_identifier with_indicator write_option _replacing_line
14578 {
14579 }
14580 ;
14581
14582 _from_identifier:
14583 /* empty */
14584 | from_identifier
14585 ;
14586
14587 from_identifier:
14588 FROM identifier
14589 {
14590 }
14591 ;
14592
14593 with_indicator:
14594 _with identifier
14595 | _with ESI
14596 | _with EMI
14597 | _with EGI
14598 ;
14599
14600 _replacing_line:
14601 /* empty */
14602 | REPLACING _line
14603 ;
14604
14605 /* SET statement */
14606
14607 set_statement:
14608 SET
14609 {
14610 begin_statement ("SET", 0);
14611 set_attr_val_on = 0;
14612 set_attr_val_off = 0;
14613 cobc_cs_check = CB_CS_SET;
14614 }
14615 set_body
14616 {
14617 cobc_cs_check = 0;
14618 }
14619 ;
14620
14621 set_body:
14622 set_environment
14623 | set_attr
14624 | set_to
14625 | set_up_down
14626 | set_to_on_off_sequence
14627 | set_to_true_false_sequence
14628 | set_last_exception_to_off
14629 | set_thread_priority
14630 ;
14631
14632 on_or_off:
14633 ON { $$ = cb_int1; }
14634 | OFF { $$ = cb_int0; }
14635 ;
14636
14637 up_or_down:
14638 UP { $$ = cb_int0; }
14639 | DOWN { $$ = cb_int1; }
14640 ;
14641
14642 /* SET ENVIRONMENT ... TO ... */
14643
14644 set_environment:
14645 ENVIRONMENT simple_display_value TO simple_display_value
14646 {
14647 cb_emit_setenv ($2, $4);
14648 }
14649 ;
14650
14651 /* SET name ATTRIBUTE ... */
14652
14653 set_attr:
14654 sub_identifier ATTRIBUTE set_attr_clause
14655 {
14656 cb_emit_set_attribute ($1, set_attr_val_on, set_attr_val_off);
14657 }
14658 ;
14659
14660 set_attr_clause:
14661 set_attr_one
14662 | set_attr_clause set_attr_one
14663 ;
14664
14665 set_attr_one:
14666 BELL on_or_off
14667 {
14668 bit_set_attr ($2, COB_SCREEN_BELL);
14669 }
14670 | BLINK on_or_off
14671 {
14672 bit_set_attr ($2, COB_SCREEN_BLINK);
14673 }
14674 | HIGHLIGHT on_or_off
14675 {
14676 bit_set_attr ($2, COB_SCREEN_HIGHLIGHT);
14677 check_not_highlight_and_lowlight (set_attr_val_on | set_attr_val_off,
14678 COB_SCREEN_HIGHLIGHT);
14679 }
14680 | LOWLIGHT on_or_off
14681 {
14682 bit_set_attr ($2, COB_SCREEN_LOWLIGHT);
14683 check_not_highlight_and_lowlight (set_attr_val_on | set_attr_val_off,
14684 COB_SCREEN_LOWLIGHT);
14685 }
14686 | REVERSE_VIDEO on_or_off
14687 {
14688 bit_set_attr ($2, COB_SCREEN_REVERSE);
14689 }
14690 | UNDERLINE on_or_off
14691 {
14692 bit_set_attr ($2, COB_SCREEN_UNDERLINE);
14693 }
14694 | LEFTLINE on_or_off
14695 {
14696 bit_set_attr ($2, COB_SCREEN_LEFTLINE);
14697 }
14698 | OVERLINE on_or_off
14699 {
14700 bit_set_attr ($2, COB_SCREEN_OVERLINE);
14701 }
14702 ;
14703
14704 /* SET name ... TO expr */
14705
14706 set_to:
14707 target_x_list TO ENTRY alnum_or_id
14708 {
14709 cb_emit_set_to ($1, cb_build_ppointer ($4));
14710 }
14711 | target_x_list TO x
14712 {
14713 cb_emit_set_to ($1, $3);
14714 }
14715 | target_x_list TO SIZE OF x /* ACUCOBOL extension, cater for dialect setting later */
14716 {
14717 cb_emit_move (cb_build_length ($5), $1);
14718 }
14719 ;
14720
14721 /* SET name ... UP/DOWN BY expr */
14722
14723 set_up_down:
14724 target_x_list up_or_down BY x
14725 {
14726 cb_emit_set_up_down ($1, $2, $4);
14727 }
14728 ;
14729
14730 /* SET mnemonic-name-1 ... TO ON/OFF */
14731
14732 set_to_on_off_sequence:
14733 set_to_on_off
14734 | set_to_on_off_sequence set_to_on_off
14735 ;
14736
14737 set_to_on_off:
14738 mnemonic_name_list TO on_or_off
14739 {
14740 cb_emit_set_on_off ($1, $3);
14741 }
14742 ;
14743
14744 /* SET condition-name-1 ... TO TRUE/FALSE */
14745
14746 set_to_true_false_sequence:
14747 set_to_true_false
14748 | set_to_true_false_sequence set_to_true_false
14749 ;
14750
14751 set_to_true_false:
14752 target_x_list TO TOK_TRUE
14753 {
14754 cb_emit_set_true ($1);
14755 }
14756 | target_x_list TO TOK_FALSE
14757 {
14758 cb_emit_set_false ($1);
14759 }
14760 ;
14761
14762 /* SET LAST EXCEPTION TO OFF */
14763
14764 set_last_exception_to_off:
14765 LAST EXCEPTION TO OFF
14766 {
14767 cb_emit_set_last_exception_to_off ();
14768 }
14769 ;
14770
14771 /* SET THREAD thread-handle PRIORITY TO priority */
14772
14773 set_thread_priority:
14774 thread_reference_optional PRIORITY TO pos_num_id_or_lit_or_zero
14775 {
14776 cb_emit_set_thread_priority ($1, $4);
14777 CB_PENDING ("THREAD");
14778 }
14779 ;
14780
14781
14782 /* SORT statement */
14783
14784 sort_statement:
14785 SORT
14786 {
14787 begin_statement ("SORT", 0);
14788 }
14789 sort_body
14790 ;
14791
14792 sort_body:
14793 table_identifier _sort_key_list _sort_duplicates _sort_collating
14794 {
14795 cb_tree x = cb_ref ($1);
14796
14797 $$ = NULL;
14798 if (CB_VALID_TREE (x)) {
14799 if ($2 == NULL || CB_VALUE($2) == NULL) {
14800 if (CB_FILE_P (x)) {
14801 cb_error (_("file sort requires KEY phrase"));
14802 $2 = cb_error_node;
14803 } else {
14804 struct cb_field *f = CB_FIELD_PTR (x);
14805 /* TODO: add compiler configuration cb_sort_without_keys
14806 if (f->nkeys
14807 && cb_verify (cb_sort_without_keys, _("table SORT without keys"))) {
14808 */
14809 if ($2 != NULL || f->nkeys) {
14810 cb_tree lparm;
14811 if ($2 == NULL) {
14812 /* create reference to first key */
14813 x = cb_ref (f->keys[0].key);
14814 }
14815 /* use the OCCURS field / its defined KEY as single sort key */
14816 lparm = cb_list_add (NULL, x);
14817 /* search order is either specified, otherwise derived from definition */
14818 if ($2 != NULL) {
14819 CB_PURPOSE (lparm) = CB_PURPOSE ($2);
14820 } else {
14821 CB_PURPOSE (lparm) = cb_int (f->keys[0].dir);
14822 }
14823 $2 = cb_list_append (NULL, lparm);
14824 } else {
14825 cb_error (_("table SORT requires KEY phrase"));
14826 $2 = cb_error_node;
14827 }
14828 }
14829 }
14830 if (CB_VALID_TREE ($2)) {
14831 cb_emit_sort_init ($1, $2, alphanumeric_collation, national_collation);
14832 $$ = $1;
14833 }
14834 }
14835 }
14836 sort_input sort_output
14837 {
14838 if ($5 && CB_VALID_TREE ($1)) {
14839 cb_emit_sort_finish ($1);
14840 }
14841 }
14842 ;
14843
14844 _sort_key_list:
14845 /* empty */ { $$ = NULL; }
14846 | _sort_key_list
14847 _on ascending_or_descending _key _key_sort_list
14848 {
14849 cb_tree lparm = $5;
14850 cb_tree l;
14851
14852 if (lparm == NULL) {
14853 lparm = CB_LIST_INIT (NULL);
14854 }
14855 for (l = lparm; l; l = CB_CHAIN (l)) {
14856 CB_PURPOSE (l) = $3;
14857 }
14858 $$ = cb_list_append ($1, lparm);
14859 }
14860 ;
14861
14862 _key_sort_list:
14863 /* empty */ { $$ = NULL; }
14864 | _key_sort_list qualified_word { $$ = cb_list_add ($1, $2); }
14865 ;
14866
14867 _sort_duplicates:
14868 | _with DUPLICATES _in_order
14869 {
14870 /* The GnuCOBOL sort is a stable sort. ie. dups are per default in order */
14871 /* Therefore nothing to do here */
14872 }
14873 ;
14874
14875 _sort_collating:
14876 /* empty */
14877 {
14878 alphanumeric_collation = national_collation = NULL;
14879 }
14880 | collating_sequence
14881 ;
14882
14883 sort_input:
14884 /* empty */
14885 {
14886 if ($0 && CB_FILE_P (cb_ref ($0))) {
14887 cb_error (_("file sort requires USING or INPUT PROCEDURE"));
14888 }
14889 }
14890 | USING file_name_list
14891 {
14892 if ($0) {
14893 if (!CB_FILE_P (cb_ref ($0))) {
14894 cb_error (_("USING invalid with table SORT"));
14895 } else {
14896 cb_emit_sort_using ($0, $2);
14897 }
14898 }
14899 }
14900 | INPUT PROCEDURE _is perform_procedure
14901 {
14902 if ($0) {
14903 if (!CB_FILE_P (cb_ref ($0))) {
14904 cb_error (_("INPUT PROCEDURE invalid with table SORT"));
14905 } else if (current_statement->flag_merge) {
14906 cb_error (_("INPUT PROCEDURE invalid with MERGE"));
14907 } else {
14908 cb_emit_sort_input ($4);
14909 }
14910 }
14911 cobc_cs_check = 0;
14912 }
14913 ;
14914
14915 sort_output:
14916 /* empty */
14917 {
14918 if ($-1 && CB_FILE_P (cb_ref ($-1))) {
14919 cb_error (_("file sort requires GIVING or OUTPUT PROCEDURE"));
14920 }
14921 }
14922 | GIVING file_name_list
14923 {
14924 if ($-1) {
14925 if (!CB_FILE_P (cb_ref ($-1))) {
14926 cb_error (_("GIVING invalid with table SORT"));
14927 } else {
14928 cb_emit_sort_giving ($-1, $2);
14929 }
14930 }
14931 }
14932 | OUTPUT PROCEDURE _is perform_procedure
14933 {
14934 if ($-1) {
14935 if (!CB_FILE_P (cb_ref ($-1))) {
14936 cb_error (_("OUTPUT PROCEDURE invalid with table SORT"));
14937 } else {
14938 cb_emit_sort_output ($4);
14939 }
14940 }
14941 cobc_cs_check = 0;
14942 }
14943 ;
14944
14945
14946 /* START statement */
14947
14948 start_statement:
14949 START
14950 {
14951 begin_statement ("START", TERM_START);
14952 start_tree = cb_int (COB_EQ);
14953 }
14954 start_body
14955 _end_start
14956 ;
14957
14958 start_body:
14959 file_name _start_key _sizelen_clause _invalid_key_phrases
14960 {
14961 if ($3 && !$2) {
14962 cb_error_x (CB_TREE (current_statement),
14963 _("SIZE/LENGTH invalid here"));
14964 } else {
14965 cb_emit_start ($1, start_tree, $2, $3);
14966 }
14967 }
14968 ;
14969
14970 _sizelen_clause:
14971 /* empty */
14972 {
14973 $$ = NULL;
14974 }
14975 | _with size_or_length exp
14976 {
14977 $$ = $3;
14978 }
14979 ;
14980
14981 _start_key:
14982 /* empty */
14983 {
14984 $$ = NULL;
14985 }
14986 | KEY _is start_op identifier
14987 {
14988 start_tree = $3;
14989 $$ = $4;
14990 }
14991 | FIRST
14992 {
14993 start_tree = cb_int (COB_FI);
14994 $$ = NULL;
14995 }
14996 | LAST
14997 {
14998 start_tree = cb_int (COB_LA);
14999 $$ = NULL;
15000 }
15001 ;
15002
15003 start_op:
15004 eq { $$ = cb_int (COB_EQ); }
15005 | _flag_not gt { $$ = cb_int ($1 ? COB_LE : COB_GT); }
15006 | _flag_not lt { $$ = cb_int ($1 ? COB_GE : COB_LT); }
15007 | _flag_not ge { $$ = cb_int ($1 ? COB_LT : COB_GE); }
15008 | _flag_not le { $$ = cb_int ($1 ? COB_GT : COB_LE); }
15009 | disallowed_op { $$ = cb_int (COB_NE); }
15010 ;
15011
15012 disallowed_op:
15013 not_equal_op
15014 {
15015 cb_error_x (CB_TREE (current_statement),
15016 _("NOT EQUAL condition not allowed on START statement"));
15017 }
15018 ;
15019
15020 not_equal_op:
15021 NOT eq
15022 | NOT_EQUAL
15023 ;
15024
15025 _end_start:
15026 /* empty */ %prec SHIFT_PREFER
15027 {
15028 TERMINATOR_WARNING ($-2, START);
15029 }
15030 | END_START
15031 {
15032 TERMINATOR_CLEAR ($-2, START);
15033 }
15034 ;
15035
15036
15037 /* STOP statement */
15038
15039 stop_statement:
15040 STOP RUN
15041 {
15042 begin_statement ("STOP RUN", 0);
15043 cobc_cs_check = CB_CS_STOP;
15044 }
15045 stop_returning
15046 {
15047 cb_emit_stop_run ($4);
15048 check_unreached = 1;
15049 cobc_cs_check = 0;
15050 }
15051 | STOP stop_argument
15052 {
15053 begin_statement ("STOP", 0);
15054 cb_emit_display (CB_LIST_INIT ($2), cb_int0, cb_int1, NULL,
15055 NULL, 1, DEVICE_DISPLAY);
15056 cb_emit_accept (cb_null, NULL, NULL);
15057 cobc_cs_check = 0;
15058 }
15059 | STOP thread_reference_optional
15060 {
15061 begin_statement ("STOP THREAD", 0);
15062 cb_emit_stop_thread ($2);
15063 cobc_cs_check = 0;
15064 cb_warning_x (COBC_WARN_FILLER, $2, _("%s is replaced by %s"), "STOP THREAD", "STOP RUN");
15065 }
15066 ;
15067
15068 stop_returning:
15069 /* empty */
15070 {
15071 if (current_program->cb_return_code) {
15072 $$ = current_program->cb_return_code;
15073 } else {
15074 $$ = cb_int0;
15075 }
15076 }
15077 | return_give x /* common extension, should error with -std=cobolX */
15078 {
15079 $$ = $2;
15080 }
15081 | x /* RM/COBOL extension, should error with most -std */
15082 {
15083 $$ = $1;
15084 }
15085 | _with ERROR _status _status_x
15086 {
15087 if ($4) {
15088 $$ = $4;
15089 } else {
15090 $$ = cb_int1;
15091 }
15092 }
15093 | _with NORMAL _status _status_x
15094 {
15095 if ($4) {
15096 $$ = $4;
15097 } else {
15098 $$ = cb_int0;
15099 }
15100 }
15101 ;
15102
15103 _status_x:
15104 /* empty */
15105 {
15106 $$ = NULL;
15107 }
15108 | x
15109 {
15110 $$ = $1;
15111 }
15112 ;
15113
15114 stop_argument:
15115 stop_literal
15116 {
15117 cb_verify (cb_stop_literal_statement, _("STOP literal"));
15118 }
15119 | identifier
15120 {
15121 cb_verify (cb_stop_identifier_statement, _("STOP identifier"));
15122 }
15123 ;
15124
15125 stop_literal:
15126 LITERAL { $$ = $1; }
15127 | SPACE { $$ = cb_space; }
15128 | ZERO { $$ = cb_zero; }
15129 | QUOTE { $$ = cb_quote; }
15130 ;
15131
15132 /* STRING statement */
15133
15134 string_statement:
15135 STRING
15136 {
15137 begin_statement ("STRING", TERM_STRING);
15138 }
15139 string_body
15140 _end_string
15141 ;
15142
15143 string_body:
15144 string_items INTO identifier _with_pointer _on_overflow_phrases
15145 {
15146 cb_emit_string ($1, $3, $4);
15147 }
15148 ;
15149
15150 string_items:
15151 {
15152 save_tree = NULL;
15153 }
15154 string_item_list
15155 {
15156 $$ = save_tree;
15157 }
15158 ;
15159
15160 string_item_list:
15161 string_item
15162 | string_item_list string_item
15163 ;
15164
15165 string_item:
15166 x _string_delimited
15167 {
15168 if (!save_tree) {
15169 save_tree = CB_LIST_INIT ($1);
15170 } else {
15171 save_tree = cb_list_add (save_tree, $1);
15172 }
15173 if ($2) {
15174 save_tree = cb_list_add (save_tree, $2);
15175 }
15176 }
15177 ;
15178
15179 _string_delimited:
15180 /* empty */ { $$ = NULL; }
15181 | DELIMITED _by
15182 string_delimiter { $$ = $3; }
15183 ;
15184
15185 string_delimiter:
15186 SIZE { $$ = CB_BUILD_PAIR (cb_int0, NULL); }
15187 | x { $$ = CB_BUILD_PAIR ($1, NULL); }
15188 ;
15189
15190 _with_pointer:
15191 /* empty */ { $$ = NULL; }
15192 | _with POINTER _is identifier { $$ = $4; }
15193 ;
15194
15195 _end_string:
15196 /* empty */ %prec SHIFT_PREFER
15197 {
15198 TERMINATOR_WARNING ($-2, STRING);
15199 }
15200 | END_STRING
15201 {
15202 TERMINATOR_CLEAR ($-2, STRING);
15203 }
15204 ;
15205
15206
15207 /* SUBTRACT statement */
15208
15209 subtract_statement:
15210 SUBTRACT
15211 {
15212 begin_statement ("SUBTRACT", TERM_SUBTRACT);
15213 }
15214 subtract_body
15215 _end_subtract
15216 ;
15217
15218 subtract_body:
15219 x_list FROM arithmetic_x_list on_size_error_phrases
15220 {
15221 cb_emit_arithmetic ($3, '-', cb_build_binary_list ($1, '+'));
15222 }
15223 | x_list FROM x GIVING arithmetic_x_list on_size_error_phrases
15224 {
15225 cb_emit_arithmetic ($5, 0, cb_build_binary_list (CB_BUILD_CHAIN ($3, $1), '-'));
15226 }
15227 | CORRESPONDING identifier FROM identifier flag_rounded on_size_error_phrases
15228 {
15229 cb_emit_corresponding (cb_build_sub, $4, $2, $5);
15230 }
15231 | TABLE table_identifier FROM table_identifier flag_rounded _from_idx_to_idx _dest_index on_size_error_phrases
15232 {
15233 CB_PENDING ("SUBTRACT TABLE");
15234 cb_emit_tab_arithmetic (cb_build_sub, $4, $2, $5, $6, $7);
15235 }
15236 ;
15237
15238 _end_subtract:
15239 /* empty */ %prec SHIFT_PREFER
15240 {
15241 TERMINATOR_WARNING ($-2, SUBTRACT);
15242 }
15243 | END_SUBTRACT
15244 {
15245 TERMINATOR_CLEAR ($-2, SUBTRACT);
15246 }
15247 ;
15248
15249
15250 /* SUPPRESS statement */
15251
15252 suppress_statement:
15253 SUPPRESS _printing
15254 {
15255 begin_statement ("SUPPRESS", 0);
15256 if (!in_declaratives) {
15257 cb_error_x (CB_TREE (current_statement),
15258 _("SUPPRESS statement must be within DECLARATIVES"));
15259 }
15260 cb_emit_suppress (control_field);
15261 }
15262 ;
15263
15264 _printing:
15265 | PRINTING
15266 ;
15267
15268 /* TERMINATE statement */
15269
15270 terminate_statement:
15271 TERMINATE
15272 {
15273 begin_statement ("TERMINATE", 0);
15274 }
15275 terminate_body
15276 ;
15277
15278 terminate_body:
15279 report_name
15280 {
15281 #if 0 /* CHECKME: likely not needed */
15282 begin_implicit_statement ();
15283 #endif
15284 if ($1 != cb_error_node) {
15285 cb_emit_terminate ($1);
15286 }
15287 }
15288 | terminate_body report_name
15289 {
15290 begin_implicit_statement ();
15291 if ($2 != cb_error_node) {
15292 cb_emit_terminate ($2);
15293 }
15294 }
15295 ;
15296
15297 /* TRANSFORM statement */
15298
15299 transform_statement:
15300 TRANSFORM
15301 {
15302 begin_statement ("TRANSFORM", 0);
15303 }
15304 transform_body
15305 ;
15306
15307 transform_body:
15308 display_identifier FROM simple_display_value TO simple_display_all_value
15309 {
15310 cb_tree x;
15311
15312 x = cb_build_converting ($3, $5, cb_build_inspect_region_start ());
15313 cb_emit_inspect ($1, x, TRANSFORM_STATEMENT);
15314 }
15315 ;
15316
15317
15318 /* UNLOCK statement */
15319
15320 unlock_statement:
15321 UNLOCK
15322 {
15323 begin_statement ("UNLOCK", 0);
15324 }
15325 unlock_body
15326 ;
15327
15328 unlock_body:
15329 file_name _records
15330 {
15331 if (CB_VALID_TREE ($1)) {
15332 if (CB_FILE (cb_ref ($1))->organization == COB_ORG_SORT) {
15333 cb_error_x (CB_TREE (current_statement),
15334 _("UNLOCK invalid for SORT files"));
15335 } else {
15336 cb_emit_unlock ($1);
15337 }
15338 }
15339 }
15340 ;
15341
15342 /* UNSTRING statement */
15343
15344 unstring_statement:
15345 UNSTRING
15346 {
15347 begin_statement ("UNSTRING", TERM_UNSTRING);
15348 }
15349 unstring_body
15350 _end_unstring
15351 ;
15352
15353 unstring_body:
15354 /* Note: using an literal here is an extension */
15355 id_or_lit_or_func _unstring_delimited unstring_into
15356 _with_pointer _unstring_tallying _on_overflow_phrases
15357 {
15358 cb_emit_unstring ($1, $2, $3, $4, $5);
15359 }
15360 ;
15361
15362 _unstring_delimited:
15363 /* empty */ { $$ = NULL; }
15364 | DELIMITED _by
15365 unstring_delimited_list { $$ = $3; }
15366 ;
15367
15368 unstring_delimited_list:
15369 unstring_delimited_item { $$ = CB_LIST_INIT ($1); }
15370 | unstring_delimited_list OR
15371 unstring_delimited_item { $$ = cb_list_add ($1, $3); }
15372 ;
15373
15374 unstring_delimited_item:
15375 flag_all simple_display_value
15376 {
15377 $$ = cb_build_unstring_delimited ($1, $2);
15378 }
15379 ;
15380
15381 unstring_into:
15382 INTO unstring_into_item { $$ = CB_LIST_INIT ($2); }
15383 | unstring_into
15384 unstring_into_item { $$ = cb_list_add ($1, $2); }
15385 ;
15386
15387 unstring_into_item:
15388 identifier _unstring_into_delimiter _count_in
15389 {
15390 $$ = cb_build_unstring_into ($1, $2, $3);
15391 }
15392 ;
15393
15394 _unstring_into_delimiter:
15395 /* empty */ { $$ = NULL; }
15396 | DELIMITER _in identifier { $$ = $3; }
15397 ;
15398
15399 _unstring_tallying:
15400 /* empty */ { $$ = NULL; }
15401 | TALLYING _in identifier { $$ = $3; }
15402 ;
15403
15404 _end_unstring:
15405 /* empty */ %prec SHIFT_PREFER
15406 {
15407 TERMINATOR_WARNING ($-2, UNSTRING);
15408 }
15409 | END_UNSTRING
15410 {
15411 TERMINATOR_CLEAR ($-2, UNSTRING);
15412 }
15413 ;
15414
15415 /* VALIDATE statement */
15416
15417 validate_statement:
15418 VALIDATE
15419 {
15420 begin_statement ("VALIDATE", 0);
15421 }
15422 validate_fields
15423 {
15424 #if 0 /* FIXME: at least add syntax checks here */
15425 cb_emit_validate ($3);
15426 #else
15427 CB_PENDING ("VALIDATE");
15428 #endif
15429 }
15430 ;
15431
15432 validate_fields:
15433 identifier
15434 {
15435 check_validate_item ($1);
15436 $$ = CB_LIST_INIT ($1);
15437 }
15438 | validate_fields identifier
15439 {
15440 check_validate_item ($2);
15441 $$ = cb_list_add ($1, $2);
15442 }
15443 ;
15444
15445
15446 /* USE statement */
15447
15448 use_statement:
15449 USE
15450 {
15451 skip_statements = 0;
15452 in_debugging = 0;
15453 }
15454 use_phrase
15455 ;
15456
15457 use_phrase:
15458 use_file_exception
15459 | use_debugging
15460 | use_start_end
15461 | use_reporting
15462 | use_exception_list
15463 ;
15464
15465 use_file_exception:
15466 use_global _after _standard exception_or_error _procedure
15467 _on use_file_exception_target
15468 {
15469 if (!in_declaratives) {
15470 cb_error (_("USE statement must be within DECLARATIVES"));
15471 } else if (!current_section) {
15472 cb_error (_("SECTION header missing before USE statement"));
15473 } else {
15474 current_section->flag_begin = 1;
15475 current_section->flag_return = 1;
15476 current_section->flag_declarative_exit = 1;
15477 current_section->flag_real_label = 1;
15478 current_section->flag_skip_label = 0;
15479 /* TO-DO: Use cobc_ec_turn? */
15480 CB_EXCEPTION_ENABLE (COB_EC_I_O) = 1;
15481 if (use_global_ind) {
15482 current_section->flag_global = 1;
15483 current_program->global_list =
15484 cb_list_add (current_program->global_list,
15485 CB_TREE (current_section));
15486 }
15487 emit_statement (cb_build_comment ("USE AFTER ERROR"));
15488 }
15489 }
15490 ;
15491
15492 use_global:
15493 /* empty */
15494 {
15495 use_global_ind = 0;
15496 }
15497 | GLOBAL
15498 {
15499 if (current_program->prog_type == COB_MODULE_TYPE_FUNCTION) {
15500 cb_error (_("%s is invalid in a user FUNCTION"), "GLOBAL");
15501 } else {
15502 use_global_ind = 1;
15503 current_program->flag_global_use = 1;
15504 }
15505 }
15506 ;
15507
15508 use_file_exception_target:
15509 file_name_list
15510 {
15511 cb_tree l;
15512
15513 for (l = $1; l; l = CB_CHAIN (l)) {
15514 if (CB_VALID_TREE (CB_VALUE (l))) {
15515 setup_use_file (CB_FILE (cb_ref (CB_VALUE (l))));
15516 }
15517 }
15518 }
15519 | INPUT
15520 {
15521 current_program->global_handler[COB_OPEN_INPUT].handler_label = current_section;
15522 current_program->global_handler[COB_OPEN_INPUT].handler_prog = current_program;
15523 }
15524 | OUTPUT
15525 {
15526 current_program->global_handler[COB_OPEN_OUTPUT].handler_label = current_section;
15527 current_program->global_handler[COB_OPEN_OUTPUT].handler_prog = current_program;
15528 }
15529 | I_O
15530 {
15531 current_program->global_handler[COB_OPEN_I_O].handler_label = current_section;
15532 current_program->global_handler[COB_OPEN_I_O].handler_prog = current_program;
15533 }
15534 | EXTEND
15535 {
15536 current_program->global_handler[COB_OPEN_EXTEND].handler_label = current_section;
15537 current_program->global_handler[COB_OPEN_EXTEND].handler_prog = current_program;
15538 }
15539 ;
15540
15541 use_debugging:
15542 _for DEBUGGING _on debugging_list
15543 {
15544 cb_tree plabel;
15545 char name[64];
15546
15547 cb_verify (cb_use_for_debugging, "USE FOR DEBUGGING");
15548
15549 if (!in_declaratives) {
15550 cb_error (_("USE statement must be within DECLARATIVES"));
15551 } else if (current_program->nested_level) {
15552 cb_error (_("USE DEBUGGING not supported in contained program"));
15553 } else {
15554 in_debugging = 1;
15555 current_section->flag_begin = 1;
15556 current_section->flag_return = 1;
15557 current_section->flag_declarative_exit = 1;
15558 current_section->flag_real_label = 0;
15559 current_section->flag_is_debug_sect = 1;
15560 if (!needs_debug_item) {
15561 needs_debug_item = 1;
15562 cb_build_debug_item ();
15563 }
15564 if (!current_program->flag_debugging) {
15565 skip_statements = 1;
15566 current_section->flag_skip_label = 1;
15567 } else {
15568 current_program->flag_gen_debug = 1;
15569 sprintf (name, "EXIT SECTION %d", cb_id);
15570 plabel = cb_build_reference (name);
15571 plabel = cb_build_label (plabel, NULL);
15572 CB_LABEL (plabel)->flag_begin = 1;
15573 CB_LABEL (plabel)->flag_dummy_exit = 1;
15574 current_section->exit_label = plabel;
15575 emit_statement (cb_build_comment ("USE FOR DEBUGGING"));
15576 }
15577 }
15578 }
15579 ;
15580
15581 debugging_list:
15582 debugging_target
15583 | debugging_list debugging_target
15584 ;
15585
15586 debugging_target:
15587 identifier_1 /* note: check for subscript/refmod in typeck.c */
15588 {
15589 if (current_program->flag_debugging) {
15590
15591 cb_tree z = CB_LIST_INIT ($1);
15592 current_program->debug_list =
15593 cb_list_append (current_program->debug_list, z);
15594 /* Check backward refs to file/data names */
15595 if (CB_WORD_COUNT ($1) > 0) {
15596 cb_tree l = CB_VALUE (CB_WORD_ITEMS ($1));
15597 switch (CB_TREE_TAG (l)) {
15598 case CB_TAG_CD:
15599 if (CB_CD (l)->flag_field_debug) {
15600 cb_error_x ($1, _("duplicate DEBUGGING target: '%s'"),
15601 cb_name (l));
15602 } else {
15603 CB_CD (l)->debug_section = current_section;
15604 CB_CD (l)->flag_field_debug = 1;
15605 }
15606 break;
15607 case CB_TAG_FILE:
15608 if (CB_FILE (l)->flag_fl_debug) {
15609 cb_error_x ($1, _("duplicate DEBUGGING target: '%s'"),
15610 cb_name (l));
15611 } else {
15612 CB_FILE (l)->debug_section = current_section;
15613 CB_FILE (l)->flag_fl_debug = 1;
15614 }
15615 break;
15616 case CB_TAG_FIELD:
15617 {
15618 struct cb_field* fld;
15619 cb_tree x = cb_ref ($1);
15620 if (!x || !CB_FIELD_P (x)) {
15621 break;
15622 }
15623 fld = CB_FIELD (x);
15624 if (fld->flag_item_78) {
15625 cb_error_x ($1, _("constant item cannot be used here"));
15626 } else if (fld->flag_field_debug) {
15627 cb_error_x ($1, _("duplicate DEBUGGING target: '%s'"),
15628 cb_name (x));
15629 } else {
15630 needs_field_debug = 1;
15631 fld->debug_section = current_section;
15632 fld->flag_field_debug = 1;
15633 CB_PURPOSE (z) = x;
15634 }
15635 }
15636 break;
15637 default:
15638 /* Label refs will be checked later (forward/backward ref) */
15639 break;
15640 }
15641 }
15642 CB_REFERENCE ($1)->debug_section = current_section;
15643 CB_REFERENCE ($1)->flag_debug_code = 1;
15644 CB_REFERENCE ($1)->flag_all_debug = 0;
15645 }
15646 }
15647 | ALL PROCEDURES
15648 {
15649 if (current_program->flag_debugging) {
15650 if (current_program->all_procedure) {
15651 cb_error (_("duplicate USE DEBUGGING ON ALL PROCEDURES"));
15652 } else {
15653 current_program->all_procedure = current_section;
15654 }
15655 }
15656 }
15657 | ALL _all_refs identifier_field /* note: check for subscript/refmod in typeck.c */
15658 {
15659 if (current_program->flag_debugging && $3 != cb_error_node) {
15660 cb_tree x = cb_ref ($3);
15661 struct cb_field *fld = CB_FIELD (x);
15662 if (fld->flag_field_debug) {
15663 cb_error_x ($3, _("duplicate DEBUGGING target: '%s'"),
15664 cb_name (x));
15665 } else {
15666 struct cb_reference *r = CB_REFERENCE ($3);
15667 needs_field_debug = 1;
15668 fld->debug_section = current_section;
15669 fld->flag_field_debug = 1;
15670 fld->flag_all_debug = 1;
15671 r->debug_section = current_section;
15672 r->flag_debug_code = 1;
15673 r->flag_all_debug = 1;
15674 CB_CHAIN_PAIR (current_program->debug_list, x, $3);
15675 }
15676 }
15677 }
15678 ;
15679
15680 _all_refs:
15681 | REFERENCES
15682 | REFERENCES OF
15683 | OF
15684 ;
15685
15686 use_start_end:
15687 _at PROGRAM program_start_end
15688 {
15689 if (current_program->nested_level) {
15690 cb_error (_("%s is invalid in nested program"), "USE AT");
15691 }
15692 }
15693 ;
15694
15695 program_start_end:
15696 START
15697 {
15698 emit_statement (cb_build_comment ("USE AT PROGRAM START"));
15699 backup_current_pos ();
15700 CB_PENDING ("USE AT PROGRAM START");
15701 /* emit_entry ("_AT_START", 0, NULL, NULL); */
15702 }
15703 | END
15704 {
15705 emit_statement (cb_build_comment ("USE AT PROGRAM END"));
15706 backup_current_pos ();
15707 CB_PENDING ("USE AT PROGRAM END");
15708 /* emit_entry ("_AT_END", 0, NULL, NULL); */
15709 }
15710 ;
15711
15712
15713 use_reporting:
15714 use_global BEFORE REPORTING identifier
15715 {
15716 char *wrk;
15717 cb_tree x;
15718 struct cb_field *f;
15719 struct cb_report *r;
15720
15721 x = cb_ref ($4);
15722 if (!CB_FIELD_P (x)) {
15723 cb_error_x ($4, _("'%s' is not a report group"), CB_NAME ($4));
15724 $$ = cb_error_node;
15725 } else {
15726 control_field = f = CB_FIELD (x);
15727 f->report_decl_id = current_section->id;
15728 if ((r = f->report) != NULL) {
15729 r->has_declarative = 1;
15730 }
15731 }
15732 wrk = cobc_main_malloc (COB_MINI_BUFF);
15733 snprintf (wrk, COB_MINI_MAX, "USE BEFORE REPORTING %s is %s%d",
15734 cb_name ($4), CB_PREFIX_LABEL, current_section->id);
15735 current_section->flag_real_label = 1;
15736 current_section->flag_declaratives = 1;
15737 current_section->flag_begin = 1;
15738 current_section->flag_return = 1;
15739 current_section->flag_declarative_exit = 1;
15740 current_section->flag_real_label = 1;
15741 current_section->flag_skip_label = 0;
15742 emit_statement (cb_build_comment (wrk));
15743 }
15744 ;
15745
15746 use_exception_list:
15747 use_exception
15748 | use_exception_list use_exception
15749 ;
15750
15751 use_exception:
15752 use_ex_keyw exception_name
15753 {
15754 current_section->flag_real_label = 1;
15755 emit_statement (cb_build_comment ("USE AFTER EXCEPTION CONDITION"));
15756 CB_PENDING ("USE AFTER EXCEPTION CONDITION");
15757 }
15758 | use_ex_keyw exception_name file_file_name_list
15759 {
15760 cb_tree l;
15761
15762 for (l = $3; l; l = CB_CHAIN (l)) {
15763 if (CB_VALID_TREE (CB_VALUE (l))) {
15764 setup_use_file (CB_FILE (cb_ref (CB_VALUE (l))));
15765 }
15766 }
15767 current_section->flag_real_label = 1;
15768 emit_statement(cb_build_comment("USE AFTER EXCEPTION CONDITION"));
15769 CB_PENDING("USE AFTER EXCEPTION CONDITION");
15770 }
15771 ;
15772
15773 use_ex_keyw:
15774 EXCEPTION_CONDITION
15775 | EC
15776 ;
15777
15778 /* WRITE statement */
15779
15780 write_statement:
15781 WRITE
15782 {
15783 begin_statement ("WRITE", TERM_WRITE);
15784 /* Special in debugging mode */
15785 save_debug = start_debug;
15786 start_debug = 0;
15787 }
15788 write_body
15789 _end_write
15790 ;
15791
15792 write_body:
15793 file_or_record_name from_option write_option _retry_phrase _with_lock write_handler
15794 {
15795 if (CB_VALID_TREE ($1)) {
15796 cb_emit_write ($1, $2, $3, $5);
15797 }
15798 start_debug = save_debug;
15799 }
15800 ;
15801
15802 from_option:
15803 /* empty */ { $$ = NULL; }
15804 | FROM from_parameter { $$ = $2; }
15805 ;
15806
15807 write_option:
15808 /* empty */
15809 {
15810 $$ = cb_int0;
15811 }
15812 | before_or_after _advancing num_id_or_lit _line_or_lines
15813 {
15814 $$ = cb_build_write_advancing_lines ($1, $3);
15815 }
15816 | before_or_after _advancing mnemonic_name
15817 {
15818 $$ = cb_build_write_advancing_mnemonic ($1, $3);
15819 }
15820 | before_or_after _advancing PAGE
15821 {
15822 $$ = cb_build_write_advancing_page ($1);
15823 }
15824 ;
15825
15826 before_or_after:
15827 BEFORE { $$ = CB_BEFORE; }
15828 | AFTER { $$ = CB_AFTER; }
15829 ;
15830
15831 write_handler:
15832 %prec SHIFT_PREFER
15833 | invalid_key_phrases
15834 | at_eop_clauses
15835 ;
15836
15837 _end_write:
15838 /* empty */ %prec SHIFT_PREFER
15839 {
15840 TERMINATOR_WARNING ($-2, WRITE);
15841 }
15842 | END_WRITE
15843 {
15844 TERMINATOR_CLEAR ($-2, WRITE);
15845 }
15846 ;
15847
15848 /* XML GENERATE statement */
15849
15850 xml_generate_statement:
15851 XML GENERATE
15852 {
15853 begin_statement ("XML GENERATE", TERM_XML);
15854 cobc_in_xml_generate_body = 1;
15855 cobc_cs_check = CB_CS_XML_GENERATE;
15856 }
15857 xml_generate_body
15858 _end_xml
15859 ;
15860
15861 xml_generate_body:
15862 identifier FROM identifier
15863 _count_in
15864 {
15865 xml_encoding = NULL;
15866 with_xml_dec = 0;
15867 with_attrs = 0;
15868 ml_suppress_list = NULL;
15869 }
15870 _with_encoding_xml_dec_and_attrs
15871 _xml_gen_namespace
15872 _xml_name_of
15873 _type_of
15874 _xml_gen_suppress
15875 {
15876 cobc_in_xml_generate_body = 0;
15877 cobc_cs_check = 0;
15878 }
15879 _xml_exception_phrases
15880 {
15881 cb_emit_xml_generate ($1, $3, $4, xml_encoding, with_xml_dec,
15882 with_attrs, $7, $8, $9, ml_suppress_list);
15883 }
15884 ;
15885
15886 _with_encoding_xml_dec_and_attrs:
15887 /* empty */
15888 | with_encoding_xml_dec_and_attrs
15889 ;
15890
15891 with_encoding_xml_dec_and_attrs:
15892 with_encoding_xml_dec_and_attr
15893 | with_encoding_xml_dec_and_attrs with_encoding_xml_dec_and_attr
15894 ;
15895
15896 with_encoding_xml_dec_and_attr:
15897 _with encoding_xml_dec_and_attr
15898 ;
15899
15900 encoding_xml_dec_and_attr:
15901 ENCODING simple_value
15902 {
15903 xml_encoding = $2;
15904 if (with_xml_dec) {
15905 cb_error (_("ENCODING clause must come before XML-DECLARATION"));
15906 } else if (with_attrs) {
15907 cb_error (_("ENCODING clause must come before ATTRIBUTES"));
15908 }
15909 cb_verify (cb_xml_generate_extra_phrases,
15910 _("XML GENERATE ENCODING clause"));
15911 CB_PENDING ("XML GENERATE ENCODING");
15912 }
15913 | XML_DECLARATION
15914 {
15915 with_xml_dec = 1;
15916 if (with_attrs) {
15917 cb_error (_("XML-DECLARATION clause must come before ATTRIBUTES"));
15918 }
15919 cb_verify (cb_xml_generate_extra_phrases,
15920 _("XML GENERATE XML-DECLARATION clause"));
15921 }
15922 | ATTRIBUTES
15923 {
15924 with_attrs = 1;
15925 cb_verify (cb_xml_generate_extra_phrases,
15926 _("XML GENERATE WITH ATTRIBUTES clause"));
15927 }
15928 ;
15929
15930 _xml_gen_namespace:
15931 /* empty */
15932 {
15933 $$ = NULL;
15934 }
15935 | NAMESPACE _is simple_value _xml_gen_namespace_prefix
15936 {
15937 $$ = CB_BUILD_PAIR ($3, $4);
15938 cb_verify (cb_xml_generate_extra_phrases,
15939 _("XML GENERATE NAMESPACE clause"));
15940 }
15941 ;
15942
15943 _xml_gen_namespace_prefix:
15944 /* empty */
15945 {
15946 $$ = cb_null;
15947 }
15948 | NAMESPACE_PREFIX _is simple_value
15949 {
15950 $$ = $3;
15951 }
15952 ;
15953
15954 _xml_name_of:
15955 /* empty */
15956 {
15957 $$ = NULL;
15958 }
15959 | NAME _of identifier_name_list
15960 {
15961 $$ = $3;
15962 cb_verify (cb_xml_generate_extra_phrases,
15963 _("XML GENERATE NAME OF clause"));
15964 }
15965 ;
15966
15967 identifier_name_list:
15968 identifier_is_name
15969 {
15970 $$ = CB_LIST_INIT ($1);
15971 }
15972 | identifier_name_list identifier_is_name
15973 {
15974 $$ = cb_list_add ($1, $2);
15975 }
15976 ;
15977
15978 identifier_is_name:
15979 identifier _is literal
15980 {
15981 $$ = CB_BUILD_PAIR ($1, $3);
15982 }
15983 ;
15984
15985 _json_name_of:
15986 /* empty */
15987 {
15988 $$ = NULL;
15989 }
15990 | NAME _of json_identifier_name_list
15991 {
15992 $$ = $3;
15993 }
15994 ;
15995
15996 json_identifier_name_list:
15997 json_identifier_is_name
15998 {
15999 $$ = CB_LIST_INIT ($1);
16000 }
16001 | json_identifier_name_list json_identifier_is_name
16002 {
16003 $$ = cb_list_add ($1, $2);
16004 }
16005 ;
16006
16007 json_identifier_is_name:
16008 identifier _is literal
16009 {
16010 $$ = CB_BUILD_PAIR ($1, $3);
16011 }
16012 | identifier _is OMITTED
16013 {
16014 $$ = CB_BUILD_PAIR ($1, cb_null);
16015 }
16016 ;
16017
16018 _type_of:
16019 /* empty */
16020 {
16021 $$ = NULL;
16022 }
16023 | TYPE _of identifier_type_list
16024 {
16025 $$ = $3;
16026 cb_verify (cb_xml_generate_extra_phrases,
16027 _("XML GENERATE TYPE OF clause"));
16028 }
16029 ;
16030
16031 identifier_type_list:
16032 identifier_is_type
16033 {
16034 $$ = CB_LIST_INIT ($1);
16035 }
16036 | identifier_type_list identifier_is_type
16037 {
16038 $$ = cb_list_add ($1, $2);
16039 }
16040 ;
16041
16042 identifier_is_type:
16043 identifier _is ml_type
16044 {
16045 $$ = CB_BUILD_PAIR ($1, $3);
16046 }
16047 ;
16048
16049 _xml_type:
16050 /* empty */
16051 {
16052 $$ = cb_int ((int) CB_ML_ANY_TYPE);
16053 }
16054 | ml_type
16055 ;
16056
16057 ml_type:
16058 ATTRIBUTE { $$ = cb_int ((int) CB_ML_ATTRIBUTE); }
16059 | ELEMENT { $$ = cb_int ((int) CB_ML_ELEMENT); }
16060 | CONTENT { $$ = cb_int ((int) CB_ML_CONTENT); }
16061 ;
16062
16063 _xml_gen_suppress:
16064 /* empty */
16065 | SUPPRESS_XML xml_suppress_list
16066 {
16067 cb_verify (cb_xml_generate_extra_phrases,
16068 _("XML GENERATE SUPPRESS clause"));
16069 }
16070 ;
16071
16072 xml_suppress_list:
16073 xml_suppress_entry
16074 | xml_suppress_list xml_suppress_entry
16075 ;
16076
16077 xml_suppress_entry:
16078 identifier
16079 {
16080 error_if_following_every_clause ();
16081 add_identifier_to_ml_suppress_conds ($1);
16082 }
16083 | EVERY xml_suppress_generic_opt
16084 {
16085 error_if_following_every_clause ();
16086 add_type_to_ml_suppress_conds (ml_suppress_category, (enum cb_ml_type) CB_INTEGER ($2)->val);
16087 }
16088 | WHEN_XML xml_suppress_when_list
16089 {
16090 add_when_to_ml_suppress_conds ($2);
16091 }
16092 ;
16093
16094 xml_suppress_generic_opt:
16095 NUMERIC _xml_type
16096 {
16097 ml_suppress_category = CB_ML_SUPPRESS_CAT_NUMERIC;
16098 $$ = $2;
16099 }
16100 | NONNUMERIC _xml_type
16101 {
16102 ml_suppress_category = CB_ML_SUPPRESS_CAT_NONNUMERIC;
16103 $$ = $2;
16104 }
16105 | ml_type
16106 {
16107 ml_suppress_category = CB_ML_SUPPRESS_CAT_ANY;
16108 $$ = $1;
16109 }
16110 ;
16111
16112 xml_suppress_when_list:
16113 zero_spaces_high_low_values
16114 {
16115 $$ = CB_LIST_INIT ($1);
16116 }
16117 | xml_suppress_when_list OR zero_spaces_high_low_values
16118 {
16119 $$ = cb_list_add ($1, $3);
16120 }
16121 ;
16122
16123 _end_xml:
16124 /* empty */ %prec SHIFT_PREFER
16125 {
16126 TERMINATOR_WARNING ($-2, XML);
16127 }
16128 | END_XML
16129 {
16130 TERMINATOR_CLEAR ($-2, XML);
16131 }
16132 ;
16133
16134
16135 /* XML PARSE statement */
16136
16137 xml_parse_statement:
16138 XML PARSE
16139 {
16140 begin_statement ("XML PARSE", TERM_XML);
16141 /* TO-DO: Add xml-parse and xml-parse-extra-phrases config options. */
16142 CB_PENDING ("XML PARSE");
16143 cobc_cs_check = CB_CS_XML_PARSE;
16144 }
16145 xml_parse_body
16146 _end_xml
16147 ;
16148
16149 xml_parse_body:
16150 identifier
16151 _with_encoding
16152 _returning_national
16153 _validating_with
16154 PROCESSING PROCEDURE _is perform_procedure
16155 {
16156 cobc_cs_check = 0;
16157 }
16158 _xml_exception_phrases
16159 ;
16160
16161 _with_encoding:
16162 /* empty */
16163 | _with ENCODING simple_value
16164 ;
16165
16166 _returning_national:
16167 /* empty */
16168 | RETURNING NATIONAL
16169 ;
16170
16171 _validating_with:
16172 /* empty */
16173 | VALIDATING _with schema_file_or_record_name
16174 ;
16175
16176 schema_file_or_record_name:
16177 record_name
16178 | TOK_FILE WORD
16179 {
16180 if (CB_FILE_P (cb_ref ($2))) {
16181 $$ = $2;
16182 } else {
16183 cb_error_x ($2, _("'%s' is not a file name"), CB_NAME ($2));
16184 $$ = cb_error_node;
16185 }
16186 }
16187 ;
16188
16189 /* Status handlers */
16190
16191 /* ON EXCEPTION */
16192
16193 _accept_exception_phrases:
16194 %prec SHIFT_PREFER
16195 | accp_on_exception _accp_not_on_exception
16196 | accp_not_on_exception _accp_on_exception
16197 {
16198 if ($2) {
16199 cb_verify (cb_not_exception_before_exception,
16200 _("NOT EXCEPTION before EXCEPTION"));
16201 }
16202 }
16203 ;
16204
16205 _accp_on_exception:
16206 %prec SHIFT_PREFER
16207 {
16208 $$ = NULL;
16209 }
16210 | accp_on_exception
16211 {
16212 $$ = cb_int1;
16213 }
16214 ;
16215
16216 accp_on_exception:
16217 escape_or_exception _key_dest statement_list
16218 {
16219 current_statement->handler_type = ACCEPT_HANDLER;
16220 current_statement->ex_handler = $3;
16221 }
16222 ;
16223
16224 escape_or_exception:
16225 ESCAPE
16226 | EXCEPTION
16227 ;
16228
16229 _accp_not_on_exception:
16230 %prec SHIFT_PREFER
16231 | accp_not_on_exception
16232 ;
16233
16234 accp_not_on_exception:
16235 not_escape_or_not_exception statement_list
16236 {
16237 current_statement->handler_type = ACCEPT_HANDLER;
16238 current_statement->not_ex_handler = $2;
16239 }
16240 ;
16241
16242 not_escape_or_not_exception:
16243 NOT_ESCAPE
16244 | NOT_EXCEPTION
16245 ;
16246
16247
16248 _display_exception_phrases:
16249 %prec SHIFT_PREFER
16250 | disp_on_exception _disp_not_on_exception
16251 | disp_not_on_exception _disp_on_exception
16252 {
16253 if ($2) {
16254 cb_verify (cb_not_exception_before_exception,
16255 _("NOT EXCEPTION before EXCEPTION"));
16256 }
16257 }
16258 ;
16259
16260 _disp_on_exception:
16261 %prec SHIFT_PREFER
16262 {
16263 $$ = NULL;
16264 }
16265 | disp_on_exception
16266 {
16267 $$ = cb_int1;
16268 }
16269 ;
16270
16271 disp_on_exception:
16272 EXCEPTION statement_list
16273 {
16274 current_statement->handler_type = DISPLAY_HANDLER;
16275 current_statement->ex_handler = $2;
16276 }
16277 ;
16278
16279 _disp_not_on_exception:
16280 %prec SHIFT_PREFER
16281 | disp_not_on_exception
16282 ;
16283
16284 disp_not_on_exception:
16285 NOT_EXCEPTION statement_list
16286 {
16287 current_statement->handler_type = DISPLAY_HANDLER;
16288 current_statement->not_ex_handler = $2;
16289 }
16290 ;
16291
16292 _xml_exception_phrases:
16293 %prec SHIFT_PREFER
16294 | xml_on_exception _xml_not_on_exception
16295 | xml_not_on_exception _xml_on_exception
16296 {
16297 if ($2) {
16298 cb_verify (cb_not_exception_before_exception,
16299 _("NOT EXCEPTION before EXCEPTION"));
16300 }
16301 }
16302 ;
16303
16304 _xml_on_exception:
16305 %prec SHIFT_PREFER
16306 {
16307 $$ = NULL;
16308 }
16309 | xml_on_exception
16310 {
16311 $$ = cb_int1;
16312 }
16313 ;
16314
16315 xml_on_exception:
16316 EXCEPTION statement_list
16317 {
16318 current_statement->handler_type = XML_HANDLER;
16319 current_statement->ex_handler = $2;
16320 }
16321 ;
16322
16323 _xml_not_on_exception:
16324 %prec SHIFT_PREFER
16325 | xml_not_on_exception
16326 ;
16327
16328 xml_not_on_exception:
16329 NOT_EXCEPTION statement_list
16330 {
16331 current_statement->handler_type = XML_HANDLER;
16332 current_statement->not_ex_handler = $2;
16333 }
16334 ;
16335
16336 _json_exception_phrases:
16337 %prec SHIFT_PREFER
16338 | json_on_exception _json_not_on_exception
16339 | json_not_on_exception _json_on_exception
16340 {
16341 if ($2) {
16342 cb_verify (cb_not_exception_before_exception,
16343 _("NOT EXCEPTION before EXCEPTION"));
16344 }
16345 }
16346 ;
16347
16348 _json_on_exception:
16349 %prec SHIFT_PREFER
16350 {
16351 $$ = NULL;
16352 }
16353 | json_on_exception
16354 {
16355 $$ = cb_int1;
16356 }
16357 ;
16358
16359 json_on_exception:
16360 EXCEPTION statement_list
16361 {
16362 current_statement->handler_type = JSON_HANDLER;
16363 current_statement->ex_handler = $2;
16364 }
16365 ;
16366
16367 _json_not_on_exception:
16368 %prec SHIFT_PREFER
16369 | json_not_on_exception
16370 ;
16371
16372 json_not_on_exception:
16373 NOT_EXCEPTION statement_list
16374 {
16375 current_statement->handler_type = JSON_HANDLER;
16376 current_statement->not_ex_handler = $2;
16377 }
16378 ;
16379
16380 /* ON SIZE ERROR */
16381
16382 on_size_error_phrases:
16383 %prec SHIFT_PREFER
16384 | on_size_error _not_on_size_error
16385 | not_on_size_error _on_size_error
16386 {
16387 if ($2) {
16388 cb_verify (cb_not_exception_before_exception,
16389 _("NOT SIZE ERROR before SIZE ERROR"));
16390 }
16391 }
16392 ;
16393
16394 _on_size_error:
16395 %prec SHIFT_PREFER
16396 {
16397 $$ = NULL;
16398 }
16399 | on_size_error
16400 {
16401 $$ = cb_int1;
16402 }
16403 ;
16404
16405 on_size_error:
16406 SIZE_ERROR statement_list
16407 {
16408 current_statement->handler_type = SIZE_ERROR_HANDLER;
16409 current_statement->ex_handler = $2;
16410 }
16411 ;
16412
16413 _not_on_size_error:
16414 %prec SHIFT_PREFER
16415 | not_on_size_error
16416 ;
16417
16418 not_on_size_error:
16419 NOT_SIZE_ERROR statement_list
16420 {
16421 current_statement->handler_type = SIZE_ERROR_HANDLER;
16422 current_statement->not_ex_handler = $2;
16423 }
16424 ;
16425
16426 /* ON OVERFLOW */
16427
16428 _on_overflow_phrases:
16429 %prec SHIFT_PREFER
16430 | on_overflow _not_on_overflow
16431 | not_on_overflow _on_overflow
16432 {
16433 if ($2) {
16434 cb_verify (cb_not_exception_before_exception,
16435 _("NOT OVERFLOW before OVERFLOW"));
16436 }
16437 }
16438 ;
16439
16440 _on_overflow:
16441 %prec SHIFT_PREFER
16442 {
16443 $$ = NULL;
16444 }
16445 | on_overflow
16446 {
16447 $$ = cb_int1;
16448 }
16449 ;
16450
16451 on_overflow:
16452 TOK_OVERFLOW statement_list
16453 {
16454 current_statement->handler_type = OVERFLOW_HANDLER;
16455 current_statement->ex_handler = $2;
16456 }
16457 ;
16458
16459 _not_on_overflow:
16460 %prec SHIFT_PREFER
16461 | not_on_overflow
16462 ;
16463
16464 not_on_overflow:
16465 NOT_OVERFLOW statement_list
16466 {
16467 current_statement->handler_type = OVERFLOW_HANDLER;
16468 current_statement->not_ex_handler = $2;
16469 }
16470 ;
16471
16472
16473 /* AT END */
16474
16475 return_at_end:
16476 at_end_clause _not_at_end_clause
16477 | not_at_end_clause at_end_clause
16478 {
16479 cb_verify (cb_not_exception_before_exception, "NOT AT END before AT END");
16480 }
16481 ;
16482
16483 at_end:
16484 %prec SHIFT_PREFER
16485 at_end_clause _not_at_end_clause
16486 | not_at_end_clause _at_end_clause
16487 {
16488 if ($2) {
16489 cb_verify (cb_not_exception_before_exception, "NOT AT END before AT END");
16490 }
16491 }
16492 ;
16493
16494 _at_end_clause:
16495 %prec SHIFT_PREFER
16496 {
16497 $$ = NULL;
16498 }
16499 | at_end_clause
16500 {
16501 $$ = cb_int1;
16502 }
16503 ;
16504
16505 at_end_clause:
16506 END statement_list
16507 {
16508 current_statement->handler_type = AT_END_HANDLER;
16509 current_statement->ex_handler = $2;
16510 }
16511 ;
16512
16513 _not_at_end_clause:
16514 %prec SHIFT_PREFER
16515 | not_at_end_clause
16516 ;
16517
16518 not_at_end_clause:
16519 NOT_END statement_list
16520 {
16521 current_statement->handler_type = AT_END_HANDLER;
16522 current_statement->not_ex_handler = $2;
16523 }
16524 ;
16525
16526 /* AT EOP */
16527
16528 at_eop_clauses:
16529 at_eop_clause _not_at_eop_clause
16530 | not_at_eop_clause _at_eop_clause
16531 {
16532 if ($2) {
16533 cb_verify (cb_not_exception_before_exception,
16534 _("NOT AT END-OF-PAGE before AT END-OF-PAGE"));
16535 }
16536 }
16537 ;
16538
16539 _at_eop_clause:
16540 %prec SHIFT_PREFER
16541 {
16542 $$ = NULL;
16543 }
16544 | at_eop_clause
16545 {
16546 $$ = cb_int1;
16547 }
16548 ;
16549
16550 at_eop_clause:
16551 EOP statement_list
16552 {
16553 current_statement->handler_type = EOP_HANDLER;
16554 current_statement->ex_handler = $2;
16555 }
16556 ;
16557
16558 _not_at_eop_clause:
16559 %prec SHIFT_PREFER
16560 | not_at_eop_clause
16561 ;
16562
16563 not_at_eop_clause:
16564 NOT_EOP statement_list
16565 {
16566 current_statement->handler_type = EOP_HANDLER;
16567 current_statement->not_ex_handler = $2;
16568 }
16569 ;
16570
16571 /* INVALID KEY */
16572
16573 _invalid_key_phrases:
16574 %prec SHIFT_PREFER
16575 | invalid_key_phrases
16576 ;
16577
16578 invalid_key_phrases:
16579 invalid_key_sentence _not_invalid_key_sentence
16580 | not_invalid_key_sentence _invalid_key_sentence
16581 {
16582 if ($2) {
16583 cb_verify (cb_not_exception_before_exception,
16584 _("NOT INVALID KEY before INVALID KEY"));
16585 }
16586 }
16587 ;
16588
16589 _invalid_key_sentence:
16590 %prec SHIFT_PREFER
16591 {
16592 $$ = NULL;
16593 }
16594 | invalid_key_sentence
16595 {
16596 $$ = cb_int1;
16597 }
16598 ;
16599
16600 invalid_key_sentence:
16601 INVALID_KEY statement_list
16602 {
16603 current_statement->handler_type = INVALID_KEY_HANDLER;
16604 current_statement->ex_handler = $2;
16605 }
16606 ;
16607
16608 _not_invalid_key_sentence:
16609 %prec SHIFT_PREFER
16610 | not_invalid_key_sentence
16611 ;
16612
16613 not_invalid_key_sentence:
16614 NOT_INVALID_KEY statement_list
16615 {
16616 current_statement->handler_type = INVALID_KEY_HANDLER;
16617 current_statement->not_ex_handler = $2;
16618 }
16619 ;
16620
16621 /* THREAD constructs */
16622
16623 _thread_start:
16624 /* empty */
16625 {
16626 $$ = NULL;
16627 }
16628 | _in THREAD
16629 {
16630 $$ = cb_int1;
16631 CB_PENDING ("THREAD");
16632 }
16633 ;
16634
16635 _thread_handle:
16636 /* empty */
16637 {
16638 $$ = NULL;
16639 }
16640 | HANDLE _in identifier
16641 {
16642 $$ = $3;
16643 CB_PENDING ("THREAD");
16644 }
16645 ;
16646
16647 thread_reference_optional:
16648 THREAD identifier
16649 {
16650 $$ = $2;
16651 }
16652 | THREAD
16653 {
16654 $$ = NULL;
16655 }
16656 ;
16657
16658 /* Common Constructs */
16659
16660 _scroll_lines:
16661 /* empty */ %prec SHIFT_PREFER
16662 {
16663 $$ = cb_one;
16664 }
16665 | pos_num_id_or_lit line_or_lines
16666 {
16667 $$ = $1;
16668 }
16669 ;
16670
16671 _count_in:
16672 /* empty */ { $$ = NULL; }
16673 | COUNT _in identifier { $$ = $3; }
16674 ;
16675
16676 /* Expressions */
16677
16678 condition:
16679 expr
16680 {
16681 $$ = cb_build_cond ($1);
16682 cb_end_cond ($$);
16683 }
16684 | error
16685 {
16686 $$ = cb_error_node;
16687 cb_end_cond ($$);
16688 }
16689 ;
16690
16691 expr:
16692 partial_expr
16693 {
16694 $$ = cb_build_expr ($1);
16695 }
16696 ;
16697
16698 partial_expr:
16699 {
16700 current_expr = NULL;
16701 cb_exp_line = cb_source_line;
16702 }
16703 expr_tokens
16704 {
16705 $$ = cb_list_reverse (current_expr);
16706 }
16707 ;
16708
16709 expr_tokens:
16710 expr_token
16711 | expr_tokens expr_token
16712 ;
16713
16714 expr_token:
16715 x { push_expr ('x', $1); }
16716 | _is condition_or_class
16717 /* This case is separate because _is _not_expr causes a shift/reduce error. */
16718 | IS not_expr condition_or_class
16719 /* This case is not in condition_or_class as x contains ZERO. */
16720 | IS _not_expr ZERO { push_expr ('x', cb_zero); }
16721 /* Parentheses */
16722 | TOK_OPEN_PAREN { push_expr ('(', NULL); }
16723 | TOK_CLOSE_PAREN { push_expr (')', NULL); }
16724 /* Arithmetic operators */
16725 | TOK_PLUS { push_expr ('+', NULL); }
16726 | TOK_MINUS { push_expr ('-', NULL); }
16727 | TOK_MUL { push_expr ('*', NULL); }
16728 | TOK_DIV { push_expr ('/', NULL); }
16729 | EXPONENTIATION { push_expr ('^', NULL); }
16730 /* Logical operators */
16731 | not_expr
16732 | AND { push_expr ('&', NULL); }
16733 | OR { push_expr ('|', NULL); }
16734 ;
16735
16736 _not_expr:
16737 /* empty */
16738 | not_expr
16739 ;
16740
16741 not_expr:
16742 NOT { push_expr ('!', NULL); }
16743
16744 condition_or_class:
16745 CLASS_NAME { push_expr ('C', $1); }
16746 /* Conditional operators */
16747 | eq { push_expr ('=', NULL); }
16748 | gt { push_expr ('>', NULL); }
16749 | lt { push_expr ('<', NULL); }
16750 | ge { push_expr (']', NULL); }
16751 | le { push_expr ('[', NULL); }
16752 | NOT_EQUAL { push_expr ('~', NULL); }
16753 /* Class condition */
16754 | OMITTED { push_expr ('O', NULL); }
16755 | NUMERIC { push_expr ('9', NULL); }
16756 | ALPHABETIC { push_expr ('A', NULL); }
16757 | ALPHABETIC_LOWER { push_expr ('L', NULL); }
16758 | ALPHABETIC_UPPER { push_expr ('U', NULL); }
16759 /* Sign condition */
16760 /* ZERO is defined in 'x' */
16761 | POSITIVE { push_expr ('P', NULL); }
16762 | NEGATIVE { push_expr ('N', NULL); }
16763 ;
16764
16765 eq:
16766 TOK_EQUAL
16767 | EQUAL _to
16768 ;
16769
16770 gt:
16771 TOK_GREATER
16772 | GREATER
16773 ;
16774
16775 lt:
16776 TOK_LESS
16777 | LESS
16778 ;
16779
16780 ge:
16781 GREATER_OR_EQUAL
16782 ;
16783
16784 le:
16785 LESS_OR_EQUAL
16786 ;
16787
16788 /* Arithmetic expression */
16789
16790 exp_list:
16791 exp %prec SHIFT_PREFER
16792 {
16793 $$ = CB_LIST_INIT ($1);
16794 }
16795 | exp_list _e_sep exp %prec SHIFT_PREFER
16796 {
16797 $$ = cb_list_add ($1, $3);
16798 }
16799 ;
16800
16801 _e_sep:
16802 /* empty */
16803 | COMMA_DELIM
16804 | SEMI_COLON
16805 ;
16806
16807 exp:
16808 exp TOK_PLUS exp_term { $$ = cb_build_binary_op ($1, '+', $3); }
16809 | exp TOK_MINUS exp_term { $$ = cb_build_binary_op ($1, '-', $3); }
16810 | exp_term { $$ = $1; }
16811 ;
16812
16813 exp_term:
16814 exp_term TOK_MUL exp_factor { $$ = cb_build_binary_op ($1, '*', $3); }
16815 | exp_term TOK_DIV exp_factor { $$ = cb_build_binary_op ($1, '/', $3); }
16816 | exp_factor { $$ = $1; }
16817 ;
16818
16819 exp_factor:
16820 exp_unary EXPONENTIATION exp_factor
16821 {
16822 $$ = cb_build_binary_op ($1, '^', $3);
16823 }
16824 | exp_unary { $$ = $1; }
16825 ;
16826
16827 exp_unary:
16828 TOK_PLUS exp_atom { $$ = $2; }
16829 | TOK_MINUS exp_atom { $$ = cb_build_binary_op (cb_zero, '-', $2); }
16830 | exp_atom { $$ = $1; }
16831
16832 exp_atom:
16833 TOK_OPEN_PAREN exp TOK_CLOSE_PAREN { $$ = $2; }
16834 | arith_x { $$ = $1; }
16835 ;
16836
16837
16838
16839 /* Names */
16840
16841 /* LINAGE-COUNTER LINE-COUNTER PAGE-COUNTER */
16842
16843 line_linage_page_counter:
16844 LINAGE_COUNTER
16845 {
16846 if (current_linage > 1) {
16847 cb_error (_("LINAGE-COUNTER must be qualified here"));
16848 $$ = cb_error_node;
16849 } else if (current_linage == 0) {
16850 cb_error (_("invalid LINAGE-COUNTER usage"));
16851 $$ = cb_error_node;
16852 } else {
16853 $$ = linage_file->linage_ctr;
16854 }
16855 }
16856 | LINAGE_COUNTER in_of WORD
16857 {
16858 if (CB_FILE_P (cb_ref ($3))) {
16859 $$ = CB_FILE (cb_ref ($3))->linage_ctr;
16860 } else {
16861 cb_error_x ($3, _("'%s' is not a file name"), CB_NAME ($3));
16862 $$ = cb_error_node;
16863 }
16864 }
16865 | LINE_COUNTER
16866 {
16867 if (report_count > 1) {
16868 if (current_report != NULL) {
16869 $$ = current_report->line_counter;
16870 } else {
16871 cb_error (_("LINE-COUNTER must be qualified here"));
16872 $$ = cb_error_node;
16873 }
16874 } else if (report_count == 0) {
16875 cb_error (_("invalid LINE-COUNTER usage"));
16876 $$ = cb_error_node;
16877 } else {
16878 $$ = report_instance->line_counter;
16879 }
16880 }
16881 | LINE_COUNTER in_of WORD
16882 {
16883 if (CB_REF_OR_REPORT_P ($3)) {
16884 $$ = CB_REPORT_PTR ($3)->line_counter;
16885 } else {
16886 cb_error_x ($3, _("'%s' is not a report name"), CB_NAME ($3));
16887 $$ = cb_error_node;
16888 }
16889 }
16890 | PAGE_COUNTER
16891 {
16892 if (report_count > 1) {
16893 if (current_report != NULL) {
16894 $$ = current_report->page_counter;
16895 } else {
16896 cb_error (_("PAGE-COUNTER must be qualified here"));
16897 $$ = cb_error_node;
16898 }
16899 } else if (report_count == 0) {
16900 cb_error (_("invalid PAGE-COUNTER usage"));
16901 $$ = cb_error_node;
16902 } else {
16903 $$ = report_instance->page_counter;
16904 }
16905 }
16906 | PAGE_COUNTER in_of WORD
16907 {
16908 if (CB_REF_OR_REPORT_P ($3)) {
16909 $$ = CB_REPORT_PTR ($3)->page_counter;
16910 } else {
16911 cb_error_x ($3, _("'%s' is not a report name"), CB_NAME ($3));
16912 $$ = cb_error_node;
16913 }
16914 }
16915 ;
16916
16917
16918 /* Data name */
16919
16920 arithmetic_x_list:
16921 arithmetic_x { $$ = $1; }
16922 | arithmetic_x_list
16923 arithmetic_x { $$ = cb_list_append ($1, $2); }
16924 ;
16925
16926 arithmetic_x:
16927 target_x flag_rounded
16928 {
16929 $$ = CB_BUILD_PAIR ($2, $1);
16930 }
16931 ;
16932
16933 /* Record name */
16934
16935 record_name:
16936 qualified_word { cb_build_identifier ($1, 0); }
16937 ;
16938
16939 /* FILE name -or- Record-name */
16940
16941 file_or_record_name:
16942 record_name
16943 {
16944 if (!CB_FILE_P (cb_ref ($1))) {
16945 $$ = $1;
16946 } else {
16947 cb_error_x ($1, _("%s requires a record name as subject"),
16948 current_statement->name);
16949 $$ = cb_error_node;
16950 }
16951 }
16952 | TOK_FILE WORD
16953 {
16954 if (CB_FILE_P (cb_ref ($2))) {
16955 $$ = $2;
16956 } else {
16957 cb_error_x ($2, _("'%s' is not a file name"), CB_NAME ($2));
16958 $$ = cb_error_node;
16959 }
16960 }
16961 ;
16962
16963 /* Table name */
16964
16965 table_name:
16966 qualified_word
16967 {
16968 cb_tree x;
16969
16970 x = cb_ref ($1);
16971 if (!CB_FIELD_P (x)) {
16972 $$ = cb_error_node;
16973 } else if (!CB_FIELD (x)->index_list) {
16974 cb_error_x ($1, _("'%s' not indexed"), cb_name ($1));
16975 cb_note_x (COB_WARNOPT_NONE, x, _("'%s' defined here"), cb_name (x));
16976 $$ = cb_error_node;
16977 } else {
16978 $$ = $1;
16979 }
16980 }
16981 ;
16982
16983 /* File name */
16984
16985 file_name_list:
16986 file_name
16987 {
16988 $$ = CB_LIST_INIT ($1);
16989 }
16990 | file_name_list file_name
16991 {
16992 cb_tree l;
16993
16994 if (CB_VALID_TREE ($2)) {
16995 for (l = $1; l; l = CB_CHAIN (l)) {
16996 if (CB_VALID_TREE (CB_VALUE (l)) &&
16997 !strcasecmp (CB_NAME ($2), CB_NAME (CB_VALUE (l)))) {
16998 cb_error_x ($2, _("multiple reference to '%s' "),
16999 CB_NAME ($2));
17000 break;
17001 }
17002 }
17003 if (!l) {
17004 $$ = cb_list_add ($1, $2);
17005 }
17006 }
17007 }
17008 ;
17009
17010 file_file_name_list:
17011 TOK_FILE file_name
17012 {
17013 $$ = CB_LIST_INIT ($2);
17014 }
17015 | file_file_name_list TOK_FILE file_name
17016 {
17017 cb_tree l;
17018
17019 if (CB_VALID_TREE ($3)) {
17020 for (l = $1; l; l = CB_CHAIN (l)) {
17021 if (CB_VALID_TREE (CB_VALUE (l)) &&
17022 !strcasecmp (CB_NAME ($3), CB_NAME (CB_VALUE (l)))) {
17023 cb_error_x ($3, _("multiple reference to '%s' "),
17024 CB_NAME ($2));
17025 break;
17026 }
17027 }
17028 if (!l) {
17029 $$ = cb_list_add ($1, $3);
17030 }
17031 }
17032 }
17033 ;
17034
17035 file_name:
17036 WORD
17037 {
17038 if (CB_FILE_P (cb_ref ($1))) {
17039 $$ = $1;
17040 } else {
17041 cb_error_x ($1, _("'%s' is not a file name"), CB_NAME ($1));
17042 $$ = cb_error_node;
17043 }
17044 }
17045 ;
17046
17047 cd_name:
17048 WORD
17049 {
17050 if (CB_CD_P (cb_ref ($1))) {
17051 $$ = $1;
17052 } else {
17053 cb_error_x ($1, _("'%s' is not a CD name"), CB_NAME ($1));
17054 $$ = cb_error_node;
17055 }
17056 }
17057 ;
17058
17059 /* Report name */
17060
17061 report_name:
17062 WORD
17063 {
17064 if (CB_REF_OR_REPORT_P ($1)) {
17065 $$ = $1;
17066 } else {
17067 cb_error (_("'%s' is not a valid report name"), CB_NAME ($1));
17068 $$ = cb_error_node;
17069 }
17070 }
17071 ;
17072
17073 /* Mnemonic name */
17074
17075 mnemonic_name_list:
17076 mnemonic_name { $$ = CB_LIST_INIT ($1); }
17077 | mnemonic_name_list
17078 mnemonic_name { $$ = cb_list_add ($1, $2); }
17079 ;
17080
17081 mnemonic_name:
17082 MNEMONIC_NAME { $$ = $1; }
17083 ;
17084
17085 /* Entry name */
17086
17087 entry_name_list:
17088 entry_name { $$ = CB_LIST_INIT ($1); }
17089 | entry_name_list
17090 entry_name { $$ = cb_list_add ($1, $2); }
17091 ;
17092
17093 entry_name:
17094 LITERAL
17095 {
17096 $$ = cb_build_reference ((char *)(CB_LITERAL ($1)->data));
17097 }
17098 ;
17099
17100 /* Procedure name */
17101
17102 procedure_name_list:
17103 %prec SHIFT_PREFER
17104 /* empty */ { $$ = NULL; }
17105 | procedure_name_list
17106 procedure_name { $$ = cb_list_add ($1, $2); }
17107 ;
17108
17109 procedure_name:
17110 label
17111 {
17112 struct cb_reference *r = CB_REFERENCE ($1);
17113
17114 r->offset = CB_TREE (current_section);
17115 r->flag_in_decl = !!in_declaratives;
17116 r->flag_ignored = cb_set_ignore_error (-1);
17117
17118 $$ = $1;
17119 CB_ADD_TO_CHAIN ($1, current_program->label_list);
17120 }
17121 ;
17122
17123 label:
17124 qualified_word
17125 | integer_label
17126 | integer_label in_of integer_label
17127 {
17128 CB_REFERENCE ($1)->chain = $3;
17129 }
17130 ;
17131
17132 integer_label:
17133 LITERAL
17134 {
17135 $$ = cb_build_reference ((char *)(CB_LITERAL ($1)->data));
17136 $$->source_file = $1->source_file;
17137 $$->source_line = $1->source_line;
17138 }
17139 ;
17140
17141 /* Reference */
17142
17143 reference_list:
17144 reference { $$ = CB_LIST_INIT ($1); }
17145 | reference_list reference { $$ = cb_list_add ($1, $2); }
17146 ;
17147
17148 reference:
17149 qualified_word
17150 {
17151 $$ = $1;
17152 CB_ADD_TO_CHAIN ($$, current_program->reference_list);
17153 }
17154 ;
17155
17156 _reference:
17157 /* empty */ {$$ = NULL;}
17158 | reference {$$ = $1;}
17159 ;
17160
17161 single_reference_list:
17162 single_reference { $$ = CB_LIST_INIT ($1); }
17163 | single_reference_list single_reference{ $$ = cb_list_add ($1, $2); }
17164 ;
17165
17166 single_reference:
17167 unqualified_word
17168 {
17169 if (!within_typedef_definition) {
17170 CB_ADD_TO_CHAIN ($1, current_program->reference_list);
17171 }
17172 }
17173 ;
17174
17175
17176 /* FIXME: either this is "optional" then _ prefix should be used,
17177 otherwise a more specific name */
17178 optional_reference_list:
17179 optional_reference
17180 {
17181 $$ = CB_LIST_INIT ($1);
17182 }
17183 | optional_reference_list optional_reference
17184 {
17185 $$ = cb_list_add ($1, $2);
17186 }
17187 ;
17188
17189 optional_reference:
17190 WORD
17191 {
17192 $$ = $1;
17193 CB_REFERENCE($$)->flag_optional = 1;
17194 CB_ADD_TO_CHAIN ($$, current_program->reference_list);
17195 }
17196 ;
17197
17198 reference_or_literal:
17199 reference
17200 | LITERAL
17201 ;
17202
17203 /* Undefined word */
17204
17205 undefined_word:
17206 WORD
17207 {
17208 if (CB_WORD_COUNT ($1) > 0) {
17209 redefinition_error ($1);
17210 $$ = cb_error_node;
17211 } else {
17212 $$ = $1;
17213 }
17214 }
17215 | error
17216 {
17217 yyclearin;
17218 yyerrok;
17219 $$ = cb_error_node;
17220 }
17221 ;
17222
17223 /* Unique word */
17224
17225 unique_word:
17226 WORD
17227 {
17228 if (CB_REFERENCE ($1)->flag_duped || CB_WORD_COUNT ($1) > 0) {
17229 redefinition_error ($1);
17230 $$ = NULL;
17231 } else {
17232 CB_WORD_COUNT ($1)++;
17233 $$ = $1;
17234 }
17235 }
17236 ;
17237
17238 /* Primitive elements */
17239
17240 /* Primitive value */
17241
17242 target_x_list:
17243 target_x
17244 {
17245 $$ = CB_LIST_INIT ($1);
17246 }
17247 | target_x_list target_x
17248 {
17249 $$ = cb_list_add ($1, $2);
17250 }
17251 ;
17252
17253 target_x:
17254 target_identifier
17255 | basic_literal
17256 | ADDRESS _of identifier_1
17257 {
17258 $$ = cb_build_address ($3);
17259 }
17260 ;
17261
17262 _x_list:
17263 /* empty */ { $$ = NULL; }
17264 | x_list { $$ = $1; }
17265 ;
17266
17267 x_list:
17268 x
17269 {
17270 $$ = CB_LIST_INIT ($1);
17271 }
17272 | x_list x
17273 {
17274 $$ = cb_list_add ($1, $2);
17275 }
17276 ;
17277
17278 x:
17279 identifier
17280 | x_common
17281 ;
17282
17283 call_x:
17284 identifier_or_file_name
17285 | x_common
17286 ;
17287
17288 x_common:
17289 literal
17290 | function
17291 | line_linage_page_counter
17292 | length_of_register identifier_1
17293 {
17294 $$ = cb_build_length ($2);
17295 }
17296 | length_of_register basic_literal
17297 {
17298 $$ = cb_build_length ($2);
17299 }
17300 | length_of_register function
17301 {
17302 $$ = cb_build_length ($2);
17303 }
17304 | ADDRESS _of prog_or_entry alnum_or_id
17305 {
17306 $$ = cb_build_ppointer ($4);
17307 }
17308 | ADDRESS _of identifier_1
17309 {
17310 $$ = cb_build_address (check_not_88_level ($3));
17311 }
17312 | ADDRESS _of FH__FCD _of file_name
17313 {
17314 CB_PENDING ("EXTFH address");
17315 }
17316 | ADDRESS _of FH__KEYDEF _of file_name
17317 {
17318 CB_PENDING ("EXTFH address");
17319 }
17320 | MNEMONIC_NAME
17321 {
17322 cb_tree x;
17323 cb_tree switch_id;
17324
17325 x = cb_ref ($1);
17326 if (CB_VALID_TREE (x)) {
17327 if (CB_SYSTEM_NAME (x)->category != CB_SWITCH_NAME) {
17328 cb_error_x ($1, _("invalid mnemonic identifier"));
17329 $$ = cb_error_node;
17330 } else {
17331 switch_id = cb_int (CB_SYSTEM_NAME (x)->token);
17332 $$ = CB_BUILD_FUNCALL_1 ("cob_switch_value", switch_id);
17333 }
17334 } else {
17335 $$ = cb_error_node;
17336 }
17337 }
17338 ;
17339
17340 length_of_register:
17341 length_of
17342 {
17343 /* FIXME: check with "lookup_register ("LENGTH OF") != NULL"
17344 if we actually want to do this,
17345 otherwise raise an error "not defined in this dialect"
17346 */
17347 }
17348 ;
17349
17350 report_x_list:
17351 arith_x
17352 {
17353 $$ = CB_LIST_INIT ($1);
17354 }
17355 | report_x_list arith_x
17356 {
17357 $$ = cb_list_add ($1, $2);
17358 }
17359 ;
17360
17361 expr_x:
17362 identifier
17363 | basic_literal
17364 | function
17365 ;
17366
17367 arith_x:
17368 identifier
17369 | basic_literal
17370 | function
17371 | line_linage_page_counter
17372 | length_of_register identifier_1
17373 {
17374 $$ = cb_build_length ($2);
17375 }
17376 | length_of_register basic_literal
17377 {
17378 $$ = cb_build_length ($2);
17379 }
17380 | length_of_register function
17381 {
17382 $$ = cb_build_length ($2);
17383 }
17384 ;
17385
17386 arith_nonzero_x:
17387 identifier
17388 | nonzero_numeric_literal
17389 | function
17390 | length_of_register identifier_1
17391 {
17392 $$ = cb_build_length ($2);
17393 }
17394 | length_of_register basic_literal
17395 {
17396 $$ = cb_build_length ($2);
17397 }
17398 | length_of_register function
17399 {
17400 $$ = cb_build_length ($2);
17401 }
17402 ;
17403
17404 numeric_literal:
17405 LITERAL
17406 {
17407 if (CB_TREE_CATEGORY ($1) != CB_CATEGORY_NUMERIC) {
17408 cb_error_x ($1, _("a numeric literal is expected here"));
17409 $$ = cb_error_node;
17410 } else {
17411 $$ = $1;
17412 }
17413 }
17414 ;
17415
17416 non_numeric_literal:
17417 LITERAL
17418 {
17419 if (CB_TREE_CATEGORY ($1) == CB_CATEGORY_NUMERIC) {
17420 cb_error_x ($1, _("a non-numeric literal is expected here"));
17421 $$ = cb_error_node;
17422 } else {
17423 $$ = $1;
17424 }
17425 }
17426 ;
17427
17428 nonzero_numeric_literal:
17429 LITERAL
17430 {
17431 if (cb_tree_category ($1) != CB_CATEGORY_NUMERIC
17432 || cb_get_int ($1) == 0) {
17433 cb_error (_("non-zero value expected"));
17434 $$ = cb_int1;
17435 } else {
17436 $$ = $1;
17437 }
17438 }
17439 ;
17440
17441
17442 prog_or_entry:
17443 PROGRAM
17444 | ENTRY
17445 ;
17446
17447 alnum_or_id:
17448 identifier_1
17449 | LITERAL
17450 ;
17451
17452 simple_display_value:
17453 simple_value
17454 {
17455 error_if_not_usage_display_or_nonnumeric_lit ($1);
17456 }
17457 ;
17458
17459 simple_display_all_value:
17460 simple_all_value
17461 {
17462 error_if_not_usage_display_or_nonnumeric_lit ($1);
17463 }
17464 ;
17465
17466 inspect_from:
17467 display_identifier_or_alphabet_name
17468 | basic_literal
17469 {
17470 error_if_not_usage_display_or_nonnumeric_lit ($1);
17471 }
17472 ;
17473
17474 inspect_to:
17475 display_identifier_or_alphabet_name
17476 | literal
17477 {
17478 error_if_not_usage_display_or_nonnumeric_lit ($1);
17479 }
17480 ;
17481
17482 simple_value:
17483 identifier
17484 | basic_literal
17485 | function
17486 ;
17487
17488 simple_all_value:
17489 identifier
17490 | literal
17491 ;
17492
17493 id_or_lit:
17494 identifier
17495 {
17496 $$ = check_not_88_level ($1);
17497 }
17498 | LITERAL
17499 ;
17500
17501 id_or_lit_or_func:
17502 identifier
17503 {
17504 $$ = check_not_88_level ($1);
17505 }
17506 | LITERAL
17507 | function
17508 ;
17509
17510 id_or_lit_or_length_or_func:
17511 identifier
17512 {
17513 $$ = check_not_88_level ($1);
17514 }
17515 | lit_or_length
17516 | function
17517 ;
17518
17519 num_id_or_lit:
17520 sub_identifier
17521 {
17522 $$ = check_not_88_level ($1);
17523 }
17524 | integer
17525 | ZERO
17526 {
17527 $$ = cb_zero;
17528 }
17529 ;
17530
17531 /* literal not allowing zero */
17532 /* FIXME: expressions would be allowed in most cases, too */
17533 positive_id_or_lit:
17534 sub_identifier
17535 {
17536 $$ = check_not_88_level ($1);
17537 }
17538 | unsigned_pos_integer
17539 ;
17540
17541 /* literal allowing zero and figurative constant ZERO */
17542 pos_num_id_or_lit_or_zero:
17543 pos_num_id_or_lit
17544 | ZERO
17545 ;
17546
17547 /* literal allowing zero */
17548 /* FIXME: expressions would be allowed in most cases, too */
17549 pos_num_id_or_lit:
17550 sub_identifier
17551 {
17552 $$ = check_not_88_level ($1);
17553 }
17554 | integer
17555 ;
17556
17557 from_parameter:
17558 identifier
17559 {
17560 $$ = check_not_88_level ($1);
17561 }
17562 | literal
17563 | function
17564 ;
17565
17566 /* Identifier */
17567
17568 sub_identifier:
17569 sub_identifier_1 { $$ = cb_build_identifier ($1, 0); }
17570 ;
17571
17572 table_identifier:
17573 sub_identifier_1 { $$ = cb_build_identifier ($1, 1); }
17574 ;
17575
17576 sub_identifier_1:
17577 qualified_word { $$ = $1; }
17578 | qualified_word subref { $$ = $1; }
17579 ;
17580
17581 display_identifier:
17582 identifier
17583 {
17584 error_if_not_usage_display_or_nonnumeric_lit ($1);
17585 }
17586 ;
17587
17588 numeric_identifier:
17589 identifier
17590 {
17591 if ($1 != cb_error_node
17592 && cb_tree_category ($1) != CB_CATEGORY_NUMERIC) {
17593 cb_error_x ($1, _("'%s' is not numeric"), cb_name ($1));
17594 }
17595 }
17596 ;
17597
17598 identifier_or_file_name:
17599 identifier_1
17600 {
17601 cb_tree x = NULL;
17602 if (CB_REFERENCE_P ($1)) {
17603 x = cb_ref ($1);
17604 }
17605 if (x && (CB_FIELD_P (x) || CB_FILE_P (x))) {
17606 $$ = cb_build_identifier ($1, 0);
17607 } else {
17608 if (x != cb_error_node) {
17609 cb_error_x ($1, _("'%s' is not a field or file"), cb_name ($1));
17610 }
17611 $$ = cb_error_node;
17612 }
17613 }
17614 ;
17615
17616 /* guarantees a reference to a validated field-reference (or cb_error_node) */
17617 identifier_field:
17618 identifier_1
17619 {
17620 cb_tree x = NULL;
17621 if (CB_REFERENCE_P ($1)) {
17622 x = cb_ref ($1);
17623 }
17624
17625 if (x && CB_FIELD_P (x)) {
17626 $$ = $1;
17627 } else {
17628 if (x != cb_error_node) {
17629 cb_error_x ($1, _("'%s' is not a field"), cb_name ($1));
17630 }
17631 $$ = cb_error_node;
17632 }
17633 }
17634 ;
17635
17636 /* guarantees a reference to a validated field-reference which has
17637 the type attribute (or cb_error_node) */
17638 type_name:
17639 WORD
17640 {
17641 cb_tree x = NULL;
17642 if (CB_REFERENCE_P ($1)) {
17643 x = cb_ref ($1);
17644 }
17645
17646 if (x && CB_FIELD_P (x) && CB_FIELD (x)->flag_is_typedef) {
17647 $$ = $1;
17648 } else {
17649 if (x != cb_error_node) {
17650 cb_error_x ($1, _("'%s' is not a type-name"), cb_name ($1));
17651 }
17652 $$ = cb_error_node;
17653 }
17654 }
17655 ;
17656
17657 identifier:
17658 identifier_1
17659 {
17660 cb_tree x = NULL;
17661 if (CB_REFERENCE_P ($1)) {
17662 x = cb_ref ($1);
17663 }
17664 if (x && CB_FIELD_P (x)) {
17665 $$ = cb_build_identifier ($1, 0);
17666 } else {
17667 if (x != cb_error_node) {
17668 cb_error_x ($1, _("'%s' is not a field"), cb_name ($1));
17669 }
17670 $$ = cb_error_node;
17671 }
17672 }
17673 ;
17674
17675 identifier_1:
17676 qualified_word subref refmod
17677 {
17678 $$ = $1;
17679 if (start_debug) {
17680 cb_check_field_debug ($1);
17681 }
17682 }
17683 | qualified_word subref %prec SHIFT_PREFER
17684 {
17685 $$ = $1;
17686 if (start_debug) {
17687 cb_check_field_debug ($1);
17688 }
17689 }
17690 | qualified_word refmod
17691 {
17692 $$ = $1;
17693 if (start_debug) {
17694 cb_check_field_debug ($1);
17695 }
17696 }
17697 | qualified_word %prec SHIFT_PREFER
17698 {
17699 $$ = $1;
17700 if (start_debug) {
17701 cb_check_field_debug ($1);
17702 }
17703 }
17704 ;
17705
17706 identifier_list:
17707 identifier
17708 {
17709 $$ = CB_LIST_INIT ($1);
17710 }
17711 | identifier_list identifier
17712 {
17713 $$ = cb_list_add ($1, $2);
17714 }
17715 ;
17716
17717 target_identifier:
17718 target_identifier_1
17719 {
17720 $$ = cb_build_identifier ($1, 0);
17721 }
17722 | line_linage_page_counter
17723 {
17724 $$ = cb_build_identifier ($1, 0);
17725 }
17726 ;
17727
17728 target_identifier_1:
17729 qualified_word subref refmod
17730 {
17731 $$ = $1;
17732 if (CB_REFERENCE_P ($1)) {
17733 CB_REFERENCE ($1)->flag_target = 1;
17734 }
17735 if (start_debug) {
17736 cb_check_field_debug ($1);
17737 }
17738 }
17739 | qualified_word subref %prec SHIFT_PREFER
17740 {
17741 $$ = $1;
17742 if (CB_REFERENCE_P ($1)) {
17743 CB_REFERENCE ($1)->flag_target = 1;
17744 }
17745 if (start_debug) {
17746 cb_check_field_debug ($1);
17747 }
17748 }
17749 | qualified_word refmod
17750 {
17751 $$ = $1;
17752 if (CB_REFERENCE_P ($1)) {
17753 CB_REFERENCE ($1)->flag_target = 1;
17754 }
17755 if (start_debug) {
17756 cb_check_field_debug ($1);
17757 }
17758 }
17759 | qualified_word %prec SHIFT_PREFER
17760 {
17761 $$ = $1;
17762 if (CB_REFERENCE_P ($1)) {
17763 CB_REFERENCE ($1)->flag_target = 1;
17764 }
17765 if (start_debug) {
17766 cb_check_field_debug ($1);
17767 }
17768 }
17769 ;
17770
17771 display_identifier_or_alphabet_name:
17772 identifier_1
17773 {
17774 cb_tree x = NULL;
17775 $$ = $1;
17776 if (start_debug) {
17777 cb_check_field_debug ($1);
17778 }
17779 if (CB_REFERENCE_P ($1)) {
17780 x = cb_ref ($1);
17781 }
17782 if (x && CB_FIELD_P (x)) {
17783 $$ = cb_build_identifier ($1, 0);
17784 error_if_not_usage_display_or_nonnumeric_lit ($1);
17785 } else if (x && CB_ALPHABET_NAME_P (x)) {
17786 /* TODO: add check for subscript/ ref-mod here [not allowed] */
17787 $$ = cb_build_identifier ($1, 0);
17788 } else {
17789 if (x != cb_error_node) {
17790 cb_error_x ($1, _("'%s' is not a field or alphabet"), cb_name ($1));
17791 }
17792 $$ = cb_error_node;
17793 }
17794 }
17795 ;
17796
17797 qualified_word:
17798 WORD
17799 {
17800 $$ = $1;
17801 }
17802 | WORD in_of qualified_word
17803 {
17804 $$ = $1;
17805 CB_REFERENCE ($1)->chain = $3;
17806 }
17807 ;
17808
17809 unqualified_word:
17810 {
17811 start_tree = NULL; /* actually not needed - initialized for clarity only */
17812 }
17813 unqualified_word_check
17814 {
17815 if ($2 == cb_error_node) {
17816 cb_error_x (start_tree, _("a subscripted data-item cannot be used here"));
17817 }
17818 $$ = start_tree;
17819 }
17820 ;
17821
17822 unqualified_word_check:
17823 WORD
17824 {
17825 start_tree = $1;
17826 $$ = $1;
17827 }
17828 | WORD in_of unqualified_word_check
17829 {
17830 start_tree = $1;
17831 $$ = cb_error_node;
17832 }
17833 ;
17834
17835 subref:
17836 TOK_OPEN_PAREN exp_list TOK_CLOSE_PAREN
17837 {
17838 $$ = $0;
17839 CB_REFERENCE ($0)->subs = cb_list_reverse ($2);
17840 }
17841 ;
17842
17843 refmod:
17844 TOK_OPEN_PAREN exp TOK_COLON TOK_CLOSE_PAREN
17845 {
17846 CB_REFERENCE ($0)->offset = $2;
17847 }
17848 | TOK_OPEN_PAREN exp TOK_COLON exp TOK_CLOSE_PAREN
17849 {
17850 CB_REFERENCE ($0)->offset = $2;
17851 CB_REFERENCE ($0)->length = $4;
17852 }
17853 ;
17854
17855 /* Literal */
17856
17857 integer:
17858 LITERAL %prec SHIFT_PREFER
17859 {
17860 if (cb_tree_category ($1) != CB_CATEGORY_NUMERIC
17861 || !CB_LITERAL_P($1)
17862 || CB_LITERAL ($1)->sign
17863 || CB_LITERAL ($1)->scale) {
17864 cb_error (_("unsigned integer value expected"));
17865 $$ = cb_build_numeric_literal (-1, "1", 0);
17866 } else {
17867 $$ = $1;
17868 }
17869 }
17870 ;
17871
17872 symbolic_integer:
17873 LITERAL
17874 {
17875 if (cb_tree_category ($1) != CB_CATEGORY_NUMERIC) {
17876 cb_error (_("integer value expected"));
17877 $$ = cb_int1;
17878 } else if (CB_LITERAL_P ($1)
17879 && (CB_LITERAL ($1)->sign || CB_LITERAL ($1)->scale)) {
17880 cb_error (_("integer value expected"));
17881 $$ = cb_int1;
17882 } else {
17883 int n = cb_get_int ($1);
17884 if (n < 1 || n > 256) {
17885 cb_error (_("invalid symbolic integer"));
17886 $$ = cb_int1;
17887 } else {
17888 $$ = $1;
17889 }
17890 }
17891 }
17892 ;
17893
17894 unsigned_pos_integer:
17895 LITERAL
17896 {
17897 if (cb_tree_category ($1) != CB_CATEGORY_NUMERIC
17898 || !CB_LITERAL_P($1)
17899 || CB_LITERAL ($1)->sign
17900 || CB_LITERAL ($1)->scale) {
17901 cb_error (_("unsigned positive integer value expected"));
17902 $$ = cb_int1;
17903 } else {
17904 if (cb_get_int ($1) < 1) {
17905 cb_error (_("unsigned positive integer value expected"));
17906 $$ = cb_int1;
17907 } else {
17908 $$ = $1;
17909 }
17910 }
17911 }
17912 ;
17913
17914 integer_or_zero:
17915 integer
17916 {
17917 $$ = $1;
17918 }
17919 | ZERO
17920 {
17921 $$ = cb_int0;
17922 }
17923 ;
17924
17925 class_value:
17926 LITERAL
17927 {
17928 if (cb_tree_category ($1) == CB_CATEGORY_NUMERIC) {
17929 if (CB_LITERAL ($1)->sign || CB_LITERAL ($1)->scale) {
17930 cb_error (_("integer value expected"));
17931 } else {
17932 int n = cb_get_int ($1);
17933 if (n < 1 || n > 256) {
17934 cb_error (_("invalid CLASS value"));
17935 }
17936 }
17937 }
17938 $$ = $1;
17939 }
17940 | SPACE { $$ = cb_space; }
17941 | ZERO { $$ = cb_zero; }
17942 | QUOTE { $$ = cb_quote; }
17943 | HIGH_VALUE { $$ = cb_high; }
17944 | LOW_VALUE { $$ = cb_low; }
17945 | TOK_NULL { $$ = cb_null; }
17946 ;
17947
17948 literal:
17949 basic_literal
17950 {
17951 $$ = $1;
17952 }
17953 | ALL basic_value
17954 {
17955 struct cb_literal *l;
17956
17957 if (CB_LITERAL_P ($2)) {
17958 /* We must not alter the original definition */
17959 l = cobc_parse_malloc (sizeof(struct cb_literal));
17960 *l = *(CB_LITERAL($2));
17961 l->all = 1;
17962 $$ = CB_TREE (l);
17963 } else {
17964 $$ = $2;
17965 }
17966 }
17967 ;
17968
17969 basic_literal:
17970 basic_value
17971 {
17972 $$ = $1;
17973 }
17974 | basic_literal TOK_AMPER basic_value
17975 {
17976 $$ = cb_concat_literals ($1, $3);
17977 }
17978 ;
17979
17980 basic_value:
17981 LITERAL { $$ = $1; }
17982 | SPACE { $$ = cb_space; }
17983 | ZERO { $$ = cb_zero; }
17984 | QUOTE { $$ = cb_quote; }
17985 | HIGH_VALUE { $$ = cb_high; }
17986 | LOW_VALUE { $$ = cb_low; }
17987 | TOK_NULL { $$ = cb_null; }
17988 ;
17989
17990 zero_spaces_high_low_values:
17991 SPACE { $$ = cb_space; }
17992 | ZERO { $$ = cb_zero; }
17993 | HIGH_VALUE { $$ = cb_high; }
17994 | LOW_VALUE { $$ = cb_low; }
17995 ;
17996
17997 /* Function */
17998
17999 function:
18000 func_no_parm func_refmod
18001 {
18002 $$ = cb_build_intrinsic ($1, NULL, $2, 0);
18003 }
18004 | func_one_parm TOK_OPEN_PAREN expr_x TOK_CLOSE_PAREN func_refmod
18005 {
18006 $$ = cb_build_intrinsic ($1, CB_LIST_INIT ($3), $5, 0);
18007 }
18008 | func_multi_parm TOK_OPEN_PAREN exp_list TOK_CLOSE_PAREN func_refmod
18009 {
18010 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18011 }
18012 | TRIM_FUNC TOK_OPEN_PAREN trim_args TOK_CLOSE_PAREN func_refmod
18013 {
18014 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18015 }
18016 | LENGTH_FUNC TOK_OPEN_PAREN length_arg TOK_CLOSE_PAREN
18017 {
18018 $$ = cb_build_intrinsic ($1, $3, NULL, 0);
18019 }
18020 | LENGTH_FUNC TOK_OPEN_PAREN length_arg PHYSICAL TOK_CLOSE_PAREN
18021 {
18022 CB_PENDING (_("PHYSICAL argument for LENGTH functions"));
18023 $$ = cb_build_intrinsic ($1, $3, NULL, 0);
18024 }
18025 | NUMVALC_FUNC TOK_OPEN_PAREN numvalc_args TOK_CLOSE_PAREN
18026 {
18027 $$ = cb_build_intrinsic ($1, $3, NULL, 0);
18028 }
18029 | LOCALE_DATE_FUNC TOK_OPEN_PAREN locale_dt_args TOK_CLOSE_PAREN func_refmod
18030 {
18031 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18032 }
18033 | LOCALE_TIME_FUNC TOK_OPEN_PAREN locale_dt_args TOK_CLOSE_PAREN func_refmod
18034 {
18035 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18036 }
18037 | LOCALE_TIME_FROM_FUNC TOK_OPEN_PAREN locale_dt_args TOK_CLOSE_PAREN func_refmod
18038 {
18039 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18040 }
18041 | FORMATTED_DATETIME_FUNC TOK_OPEN_PAREN formatted_datetime_args TOK_CLOSE_PAREN func_refmod
18042 {
18043 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18044 }
18045 | FORMATTED_TIME_FUNC TOK_OPEN_PAREN formatted_time_args TOK_CLOSE_PAREN func_refmod
18046 {
18047 $$ = cb_build_intrinsic ($1, $3, $5, 0);
18048 }
18049 | FUNCTION_NAME func_args
18050 {
18051 $$ = cb_build_intrinsic ($1, $2, NULL, 0);
18052 }
18053 | USER_FUNCTION_NAME func_args
18054 {
18055 $$ = cb_build_intrinsic ($1, $2, NULL, 1);
18056 }
18057 ;
18058
18059 func_no_parm:
18060 CURRENT_DATE_FUNC
18061 | WHEN_COMPILED_FUNC
18062 ;
18063
18064 func_one_parm:
18065 UPPER_CASE_FUNC
18066 | LOWER_CASE_FUNC
18067 | CONTENT_LENGTH_FUNC
18068 | REVERSE_FUNC
18069 ;
18070
18071 func_multi_parm:
18072 CONCATENATE_FUNC
18073 | CONTENT_OF_FUNC
18074 | FORMATTED_DATE_FUNC
18075 | SUBSTITUTE_FUNC
18076 | SUBSTITUTE_CASE_FUNC
18077 ;
18078
18079 func_refmod:
18080 /* empty */ %prec SHIFT_PREFER
18081 {
18082 $$ = NULL;
18083 }
18084 | TOK_OPEN_PAREN exp TOK_COLON TOK_CLOSE_PAREN
18085 {
18086 $$ = CB_BUILD_PAIR ($2, NULL);
18087 }
18088 | TOK_OPEN_PAREN exp TOK_COLON exp TOK_CLOSE_PAREN
18089 {
18090 $$ = CB_BUILD_PAIR ($2, $4);
18091 }
18092 ;
18093
18094 func_args:
18095 /* empty */ %prec SHIFT_PREFER
18096 {
18097 $$ = NULL;
18098 }
18099 | TOK_OPEN_PAREN exp_list TOK_CLOSE_PAREN
18100 {
18101 $$ = $2;
18102 }
18103 | TOK_OPEN_PAREN TOK_CLOSE_PAREN
18104 {
18105 $$ = NULL;
18106 }
18107 ;
18108
18109 trim_args:
18110 expr_x
18111 {
18112 cb_tree x;
18113
18114 x = CB_LIST_INIT ($1);
18115 $$ = cb_list_add (x, cb_int0);
18116 }
18117 | expr_x _e_sep LEADING
18118 {
18119 cb_tree x;
18120
18121 x = CB_LIST_INIT ($1);
18122 $$ = cb_list_add (x, cb_int1);
18123 }
18124 | expr_x _e_sep TRAILING
18125 {
18126 cb_tree x;
18127
18128 x = CB_LIST_INIT ($1);
18129 $$ = cb_list_add (x, cb_int2);
18130 }
18131 ;
18132
18133 length_arg:
18134 {
18135 suppress_data_exceptions = 1;
18136 }
18137 expr_x
18138 {
18139 suppress_data_exceptions = 0;
18140 if (CB_NUMERIC_LITERAL_P($2)) {
18141 cb_error_x ($2, _("a non-numeric literal is expected here"));
18142 $$ = CB_LIST_INIT (cb_error_node);
18143 } else {
18144 $$ = CB_LIST_INIT ($2);
18145 }
18146 }
18147 ;
18148
18149 numvalc_args:
18150 expr_x
18151 {
18152 cb_tree x;
18153
18154 x = CB_LIST_INIT ($1);
18155 $$ = cb_list_add (x, cb_null);
18156 }
18157 | expr_x _e_sep expr_x
18158 {
18159 cb_tree x;
18160
18161 x = CB_LIST_INIT ($1);
18162 $$ = cb_list_add (x, $3);
18163 }
18164 ;
18165
18166 locale_dt_args:
18167 exp
18168 {
18169 cb_tree x;
18170
18171 x = CB_LIST_INIT ($1);
18172 $$ = cb_list_add (x, cb_null);
18173 }
18174 | exp _e_sep reference
18175 {
18176 cb_tree x;
18177
18178 x = CB_LIST_INIT ($1);
18179 $$ = cb_list_add (x, cb_ref ($3));
18180 }
18181 ;
18182
18183 formatted_datetime_args:
18184 exp_list
18185 {
18186 $$ = cb_list_add ($1, cb_int0);
18187 }
18188 | exp_list _e_sep SYSTEM_OFFSET
18189 {
18190 const int num_args = cb_list_length ($1);
18191
18192 if (num_args == 4) {
18193 cb_error_x ($1, _("cannot specify offset and SYSTEM-OFFSET at the same time"));
18194 }
18195
18196 $$ = cb_list_add ($1, cb_int1);
18197 }
18198 ;
18199
18200 formatted_time_args:
18201 exp_list
18202 {
18203 $$ = cb_list_add ($1, cb_int0);
18204 }
18205 | exp_list _e_sep SYSTEM_OFFSET
18206 {
18207 const int num_args = cb_list_length ($1);
18208
18209 if (num_args == 3) {
18210 cb_error_x ($1, _("cannot specify offset and SYSTEM-OFFSET at the same time"));
18211 }
18212
18213 $$ = cb_list_add ($1, cb_int1);
18214 }
18215 ;
18216
18217 /* Common rules */
18218
18219 not_const_word:
18220 {
18221 non_const_word = 1;
18222 }
18223 ;
18224
18225 /* Common flags */
18226
18227 flag_all:
18228 /* empty */ { $$ = cb_int0; }
18229 | ALL { $$ = cb_int1; }
18230 ;
18231
18232 flag_duplicates:
18233 /* empty */ { $$ = NULL; }
18234 | _with NO DUPLICATES { $$ = cb_int0; }
18235 | _with DUPLICATES { $$ = cb_int1; }
18236 ;
18237
18238 flag_initialized:
18239 /* empty */ { $$ = NULL; }
18240 | INITIALIZED { $$ = cb_int1; }
18241 ;
18242
18243 flag_initialized_to:
18244 /* empty */
18245 {
18246 $$ = NULL;
18247 }
18248 | INITIALIZED to_init_val
18249 {
18250 $$ = $2;
18251 }
18252 ;
18253
18254 to_init_val:
18255 /* empty */
18256 {
18257 $$ = NULL;
18258 }
18259 | TO simple_all_value
18260 {
18261 $$ = $2;
18262 }
18263 ;
18264
18265 _flag_next:
18266 %prec SHIFT_PREFER
18267 /* empty */ { $$ = cb_int0; }
18268 | NEXT { $$ = cb_int1; }
18269 | PREVIOUS { $$ = cb_int2; }
18270 ;
18271
18272 _flag_not:
18273 /* empty */ { $$ = NULL; }
18274 | NOT { $$ = cb_true; }
18275 ;
18276
18277 flag_optional:
18278 /* empty */ { $$ = cb_int (cb_flag_optional_file); }
18279 | OPTIONAL { $$ = cb_int1; }
18280 | NOT OPTIONAL { $$ = cb_int0; }
18281 ;
18282
18283 flag_rounded:
18284 /* empty */
18285 {
18286 $$ = cb_int0;
18287 }
18288 | ROUNDED round_mode
18289 {
18290 if ($2) {
18291 $$ = $2;
18292 } else {
18293 $$ = default_rounded_mode;
18294 }
18295 cobc_cs_check = 0;
18296 }
18297 ;
18298
18299 round_mode:
18300 /* empty */
18301 {
18302 $$ = NULL;
18303 cobc_cs_check = 0;
18304 }
18305 | MODE _is round_choice
18306 {
18307 $$ = $3;
18308 cobc_cs_check = 0;
18309 }
18310 ;
18311
18312 round_choice:
18313 AWAY_FROM_ZERO
18314 {
18315 $$ = cb_int (COB_STORE_ROUND | COB_STORE_AWAY_FROM_ZERO);
18316 }
18317 | NEAREST_AWAY_FROM_ZERO
18318 {
18319 $$ = cb_int (COB_STORE_ROUND | COB_STORE_NEAR_AWAY_FROM_ZERO);
18320 }
18321 | NEAREST_EVEN
18322 {
18323 $$ = cb_int (COB_STORE_ROUND | COB_STORE_NEAR_EVEN);
18324 }
18325 | NEAREST_TOWARD_ZERO
18326 {
18327 $$ = cb_int (COB_STORE_ROUND | COB_STORE_NEAR_TOWARD_ZERO);
18328 }
18329 | PROHIBITED
18330 {
18331 $$ = cb_int (COB_STORE_ROUND | COB_STORE_PROHIBITED);
18332 }
18333 | TOWARD_GREATER
18334 {
18335 $$ = cb_int (COB_STORE_ROUND | COB_STORE_TOWARD_GREATER);
18336 }
18337 | TOWARD_LESSER
18338 {
18339 $$ = cb_int (COB_STORE_ROUND | COB_STORE_TOWARD_LESSER);
18340 }
18341 | TRUNCATION
18342 {
18343 $$ = cb_int (COB_STORE_ROUND | COB_STORE_TRUNCATION);
18344 }
18345 ;
18346
18347 flag_separate:
18348 /* empty */ { $$ = NULL; }
18349 | SEPARATE _character { $$ = cb_int1; }
18350 ;
18351
18352 _from_idx_to_idx:
18353 /* empty */ { $$ = NULL; }
18354 | FROM _index pos_num_id_or_lit_or_zero TO pos_num_id_or_lit_or_zero
18355 {
18356 cb_tree x;
18357
18358 x = CB_LIST_INIT ($2);
18359 $$ = cb_list_add (x, $4);
18360 }
18361 ;
18362
18363 _dest_index:
18364 /* empty */ { $$ = NULL; }
18365 | DESTINATION _index pos_num_id_or_lit_or_zero
18366 {
18367 $$ = $3;
18368 }
18369 ;
18370
18371 /* Error recovery */
18372
18373 error_stmt_recover:
18374 TOK_DOT
18375 {
18376 cobc_repeat_last_token = 1;
18377 }
18378 | verb
18379 {
18380 cobc_repeat_last_token = 1;
18381 }
18382 | ELSE
18383 {
18384 cobc_repeat_last_token = 0;
18385 }
18386 | scope_terminator
18387 {
18388 cobc_repeat_last_token = 0;
18389 }
18390 ;
18391
18392 verb:
18393 ACCEPT
18394 | ADD
18395 | ALLOCATE
18396 | ALTER
18397 | CALL
18398 | CANCEL
18399 | CLOSE
18400 | COMMIT
18401 | COMPUTE
18402 | CONTINUE
18403 | DELETE
18404 | DISPLAY
18405 | DIVIDE
18406 | ENTRY
18407 | EVALUATE
18408 | EXIT
18409 | EXHIBIT
18410 | FREE
18411 | GENERATE
18412 | GO
18413 | GOBACK
18414 | IF
18415 | INITIALIZE
18416 | INITIATE
18417 | INSPECT
18418 | INQUIRE
18419 | MERGE
18420 | MODIFY
18421 | MOVE
18422 | MULTIPLY
18423 | NEXT
18424 | OPEN
18425 | PERFORM
18426 | READ
18427 | RELEASE
18428 | RETURN
18429 | REWRITE
18430 | ROLLBACK
18431 | SEARCH
18432 | SET
18433 | SORT
18434 | START
18435 | STOP
18436 | STRING
18437 | SUBTRACT
18438 | SUPPRESS
18439 | TERMINATE
18440 | TRANSFORM
18441 | UNLOCK
18442 | UNSTRING
18443 | WRITE
18444 | XML
18445 ;
18446
18447 scope_terminator:
18448 END_ACCEPT
18449 | END_ADD
18450 | END_CALL
18451 | END_COMPUTE
18452 | END_DELETE
18453 | END_DISPLAY
18454 | END_DIVIDE
18455 | END_EVALUATE
18456 | END_IF
18457 | END_MODIFY
18458 | END_MULTIPLY
18459 | END_PERFORM
18460 | END_READ
18461 | END_RECEIVE
18462 | END_RETURN
18463 | END_REWRITE
18464 | END_SEARCH
18465 | END_START
18466 | END_STRING
18467 | END_SUBTRACT
18468 | END_UNSTRING
18469 | END_WRITE
18470 | END_XML
18471 ;
18472
18473 /* Mandatory/Optional keyword selection without actions */
18474
18475 /* Optional selection */
18476
18477 _advancing: | ADVANCING ;
18478 _after: | AFTER ;
18479 _are: | ARE ;
18480 _area: | AREA ;
18481 _areas: | AREA | AREAS ;
18482 _as: | AS ;
18483 _at: | AT ;
18484 _before: | BEFORE ;
18485 _binary: | BINARY ;
18486 _box: | BOX ;
18487 _by: | BY ;
18488 _character: | CHARACTER ;
18489 _characters: | CHARACTERS ;
18490 _collating: | COLLATING ;
18491 _contains: | CONTAINS ;
18492 _controls: | CONTROLS ;
18493 _control: | CONTROL ;
18494 _data: | DATA ;
18495 _end_of: | _to END _of ;
18496 _erase: | ERASE ;
18497 _every: | EVERY ;
18498 _file: | TOK_FILE ;
18499 _for: | FOR ;
18500 _from: | FROM ;
18501 _in: | IN ;
18502 _in_equal: | IN | TOK_EQUAL;
18503 _in_order: | ORDER | IN ORDER ;
18504 _index: | INDEX ;
18505 _indicate: | INDICATE ;
18506 _initial: | TOK_INITIAL ;
18507 _into: | INTO ;
18508 _is: | IS ;
18509 _is_equal: | IS | TOK_EQUAL;
18510 _is_are: | IS | ARE ;
18511 _is_are_equal: | IS | ARE | TOK_EQUAL;
18512 _is_in: | IS | IN ;
18513 _key: | KEY ;
18514 _line: | LINE ;
18515 _line_or_lines: | LINE | LINES ;
18516 _limits: | LIMIT _is_are | LIMITS _is_are ;
18517 _lines: | LINES ;
18518 _lock: | LOCK ;
18519 _message: | MESSAGE ;
18520 _mode: | MODE ;
18521 _new: | NEW ;
18522 _number: | NUMBER ;
18523 _number_or_numbers: _number | NUMBERS ;
18524 _of: | OF ;
18525 _on: | ON ;
18526 _on_for: | ON | FOR ;
18527 _onoff_status: | STATUS IS | STATUS | IS ;
18528 _other: | OTHER ;
18529 _others: | OTHERS ;
18530 _procedure: | PROCEDURE ;
18531 _program: | PROGRAM ;
18532 _protected: | PROTECTED ;
18533 _record: | RECORD ;
18534 _records: | RECORD | RECORDS;
18535 _right: | RIGHT ;
18536 _sign: | SIGN ;
18537 _signed: | SIGNED ;
18538 _sign_is: | SIGN | SIGN IS ;
18539 _size: | SIZE ;
18540 _standard: | STANDARD ;
18541 _status: | STATUS ;
18542 _symbolic: | SYMBOLIC ;
18543 _tape: | TAPE ;
18544 _terminal: | TERMINAL ;
18545 _then: | THEN ;
18546 _times: | TIMES ;
18547 _to: | TO ;
18548 _up: | UP ;
18549 _when: | WHEN ;
18550 _when_set_to: | WHEN SET TO ;
18551 _with: | WITH ;
18552 _with_for: | WITH | FOR ;
18553
18554 /* Mandatory selection */
18555
18556 column_or_col: COLUMN | COL ;
18557 columns_or_cols: COLUMNS | COLS ;
18558 column_or_cols: column_or_col | columns_or_cols ;
18559 column_or_col_or_position_or_pos: COLUMN | COL | POSITION | POS ;
18560 comp_equal: TOK_EQUAL | EQUAL ;
18561 exception_or_error: EXCEPTION | ERROR ;
18562 file_limit_or_limits: FILE_LIMIT | FILE_LIMITS ;
18563 in_of: IN | OF ;
18564 label_option: STANDARD | OMITTED ;
18565 line_or_lines: LINE | LINES ;
18566 lock_records: RECORD | RECORDS ;
18567 object_char_or_word_or_modules: CHARACTERS | WORDS | MODULES;
18568 records: RECORD _is_are | RECORDS _is_are ;
18569 reel_or_unit: REEL | UNIT ;
18570 size_or_length: SIZE | LENGTH ;
18571 length_of: LENGTH | LENGTH_OF;
18572 track_or_tracks: TRACK | TRACKS ;
18573 using_or_varying: USING | VARYING ;
18574
18575 /* Mandatory R/W keywords */
18576 detail_keyword: DETAIL | DE ;
18577 ch_keyword: CONTROL HEADING | CH ;
18578 cf_keyword: CONTROL FOOTING | CF ;
18579 ph_keyword: PAGE HEADING | PH ;
18580 pf_keyword: PAGE FOOTING | PF ;
18581 rh_keyword: REPORT HEADING | RH ;
18582 rf_keyword: REPORT FOOTING | RF ;
18583 control_keyword: CONTROL _is_are | CONTROLS _is_are ;
18584
18585 %%
18586