diff --git a/cobc/ChangeLog b/cobc/ChangeLog index fea626e9a..f85beef1c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,27 @@ +2024-12-18 Emilien Lemaire + + * cobgen.c, field.c, tree.c, tree.h, typeck.c: Hand merge 2015-07-02 + about COMP-X. + * cobgen.c (output_size): use `compx_size` when usage is COMP-X + * cobgen.c (output_attr): override type to `COB_TYPE_NUMERIC_BINARY` + when usage is `COMP-X` + * field.c: Increment `pic_digits` values by one + * field.c (setup_parameters): set the `compx_size` and override usage + of `COMP-N` to `COMP-X` field when picture starts with `X` + * field.c (compute_size): leave `align_size` to 1 when usage is + `COMP-x` and use `compx_size` to compute size of `COMP-X` + * tree.c (cb_tree_category): `COMP-X` is of category + `CB_CATEGORY_NUMERIC`. + * tree.c (cb_field_size): size of `COMP-X` field and references is + `compx_size` + * tree.h (struct cob_field): add `compx_size` to `cob_field` + * typeck.c (cb_check_numeric_name): `COMP-X` is numeric name + * typeck.c (cb_check_numeric_edited_name): `COMP-X` is numeric edited + name + * typeck.c (validate_move): `COMP-x` is validated when dst is category + `ALPHANUMERIC` or `ALPHANUMERIC-EDITED`. + 2022-12-08 Simon Sobisch * cobc.c (process_command_line): fix leak for --copy and -include parsing @@ -7304,6 +7327,10 @@ * codegen.c (output_size): Fix Bug #146 reference modification ignored ODO size +2015-07-02 Ron Norman + * Fixes to tree.c, tree,h typeck.c field.c codegen.c to correctly + handle COMP-X data fields. This now works the same as Micro Focus + 2015-06-12 Edward Hart * codegen.c: bug #78 - changed location of initialization of diff --git a/cobc/codegen.c b/cobc/codegen.c index c46d67f24..3d2a6a270 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -1344,6 +1344,8 @@ output_size (const cb_tree x) } output_integer (p->depending); q = p; + } else if(q->usage == CB_USAGE_COMP_X && q->compx_size > 0) { + output ("%d", q->compx_size); } else { output ("%d", q->size); } @@ -1603,6 +1605,8 @@ output_attr (const cb_tree x) id = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0); } else { int type = cb_tree_type (x, f); + if (f->usage == CB_USAGE_COMP_X) + type = COB_TYPE_NUMERIC_BINARY; switch (type) { case COB_TYPE_GROUP: case COB_TYPE_ALPHANUMERIC: diff --git a/cobc/field.c b/cobc/field.c index bc1f458cf..af26ccdf2 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -59,7 +59,7 @@ size_t cb_needs_01 = 0; static struct cb_field *last_real_field = NULL; static int occur_align_size = 0; -static const unsigned char pic_digits[] = { 2, 4, 7, 9, 12, 14, 16, 18 }; +static const unsigned char pic_digits[] = { 3, 5, 8, 10, 13, 15, 17, 19 }; #define CB_MAX_OPS 32 static int op_pos = 1, op_val_pos; static char op_type [CB_MAX_OPS+1]; @@ -2518,9 +2518,17 @@ setup_parameters (struct cb_field *f) case CB_USAGE_COMP_5: f->flag_real_binary = 1; /* Fall-through */ - case CB_USAGE_COMP_X: case CB_USAGE_COMP_N: - if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) { + if (f->pic + && f->pic->orig + && f->pic->orig[0] == 'X') { + f->usage = CB_USAGE_COMP_X; + } + /* Fall-through */ + case CB_USAGE_COMP_X: + if (f->pic->category == CB_CATEGORY_ALPHANUMERIC + && f->usage == CB_USAGE_COMP_X) { + f->compx_size = f->size = f->pic->size; if (f->pic->size > 8) { f->pic = cb_build_picture ("9(36)"); } else { @@ -2951,8 +2959,6 @@ compute_size (struct cb_field *f) switch (c->usage) { case CB_USAGE_BINARY: case CB_USAGE_COMP_5: - case CB_USAGE_COMP_X: - case CB_USAGE_COMP_N: case CB_USAGE_FLOAT: case CB_USAGE_DOUBLE: case CB_USAGE_LONG_DOUBLE: @@ -2985,6 +2991,9 @@ compute_size (struct cb_field *f) case CB_USAGE_PROGRAM_POINTER: align_size = sizeof (void *); break; + case CB_USAGE_COMP_X: + case CB_USAGE_COMP_N: + break; default: break; } @@ -3061,6 +3070,10 @@ compute_size (struct cb_field *f) switch (f->usage) { case CB_USAGE_COMP_X: + if (f->compx_size > 0) { + size = f->compx_size; + break; + } case CB_USAGE_COMP_N: if (f->pic->category == CB_CATEGORY_ALPHANUMERIC) { break; diff --git a/cobc/tree.c b/cobc/tree.c index 0e2f9bb18..beba74146 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1461,6 +1461,8 @@ cb_tree_category (cb_tree x) x->category = CB_CATEGORY_DATA_POINTER; } else if (f->usage == CB_USAGE_PROGRAM_POINTER) { x->category = CB_CATEGORY_PROGRAM_POINTER; + } else if (f->usage == CB_USAGE_COMP_X) { + x->category = CB_CATEGORY_NUMERIC; } else if (f->pic) { x->category = f->pic->category; /* FIXME: Hack for CGI to not abort */ @@ -1531,6 +1533,9 @@ cb_tree_type (const cb_tree x, const struct cb_field *f) switch (CB_TREE_CATEGORY (x)) { case CB_CATEGORY_ALPHABETIC: case CB_CATEGORY_ALPHANUMERIC: + if (f->usage == CB_USAGE_COMP_X) { + return COB_TYPE_NUMERIC_BINARY; + } return COB_TYPE_ALPHANUMERIC; case CB_CATEGORY_ALPHANUMERIC_EDITED: return COB_TYPE_ALPHANUMERIC_EDITED; @@ -4135,6 +4140,8 @@ cb_field_size (const cb_tree x) if (f->flag_any_length) { return FIELD_SIZE_UNKNOWN; } + if (f->usage == CB_USAGE_COMP_X && f->compx_size > 0) + return f->compx_size; return f->size; } case CB_TAG_REFERENCE: { @@ -4152,6 +4159,8 @@ cb_field_size (const cb_tree x) } else { return FIELD_SIZE_UNKNOWN; } + } else if (f->usage == CB_USAGE_COMP_X && f->compx_size > 0) { + return f->compx_size; } else if (f->flag_any_length) { return FIELD_SIZE_UNKNOWN; } else { diff --git a/cobc/tree.h b/cobc/tree.h index 19878838f..21746df2c 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -914,6 +914,7 @@ struct cb_field { int size; /* Field size */ int level; /* Level number */ int memory_size; /* Memory size */ + int compx_size; /* Original COMP-X byte size */ int offset; /* Byte offset from 01 level */ int occurs_min; /* OCCURS */ int occurs_max; /* OCCURS [... TO] */ diff --git a/cobc/typeck.c b/cobc/typeck.c index 280fa922d..b22577455 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -916,6 +916,13 @@ cb_check_numeric_name (cb_tree x) return x; } + if (CB_REFERENCE_P (x) + && CB_FIELD_P (cb_ref (x))) { + const struct cb_field *f = CB_FIELD_PTR (x); + if (f->usage == CB_USAGE_COMP_X) + return x; + } + cb_error_x (x, _("'%s' is not a numeric name"), cb_name (x)); return cb_error_node; } @@ -939,6 +946,14 @@ cb_check_numeric_edited_name (cb_tree x) } } + if (CB_REFERENCE_P(x) + && CB_FIELD_P(cb_ref(x))) { + const struct cb_field *f = CB_FIELD_PTR (x); + if (f->usage == CB_USAGE_COMP_X) { + return x; + } + } + cb_error_x (x, _("'%s' is not a numeric or numeric-edited name"), cb_name (x)); return cb_error_node; } @@ -11224,6 +11239,9 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_ switch (CB_TREE_CATEGORY (dst)) { case CB_CATEGORY_ALPHANUMERIC: case CB_CATEGORY_ALPHANUMERIC_EDITED: + if (fdst->usage == CB_USAGE_COMP_X) { + break; + } if (is_value || l->scale != 0 || l->size != fdst->size) { diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index 57c4eee86..bf43bedac 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -8807,26 +8807,26 @@ AT_CAPTURE_FILE([prog.out]) AT_CHECK([$COBCRUN_DIRECT ./prog 1>prog.out], [0], [], []) -AT_DATA([reference], [Other Flags 32. +AT_DATA([reference], [Other Flags 032. File has 0003 keys. Key def 0112 bytes. File assigned is 'mytstisam' *** Dump FCD before changes -Key1 has 001 parts, Offset 062 Flags 00 Comp 00 Sparse . +Key1 has 001 parts, Offset 062 Flags 000 Comp 000 Sparse . Pos 000000000 Len 000000008 -Key2 has 002 parts, Offset 072 Flags 00 Comp 00 Sparse . +Key2 has 002 parts, Offset 072 Flags 000 Comp 000 Sparse . Pos 000000109 Len 000000010 Pos 000000144 Len 000000008 -Key3 has 002 parts, Offset 092 Flags 00 Comp 00 Sparse . +Key3 has 002 parts, Offset 092 Flags 000 Comp 000 Sparse . Pos 000000156 Len 000000008 Pos 000000164 Len 000000008 *** Dump FCD after changes -Key1 has 001 parts, Offset 062 Flags 00 Comp 00 Sparse . +Key1 has 001 parts, Offset 062 Flags 000 Comp 000 Sparse . Pos 000000000 Len 000000008 -Key2 has 002 parts, Offset 072 Flags 64 Comp 00 Sparse . +Key2 has 002 parts, Offset 072 Flags 064 Comp 000 Sparse . Pos 000000109 Len 000000010 Pos 000000144 Len 000000008 -Key3 has 002 parts, Offset 092 Flags 66 Comp 00 Sparse *. +Key3 has 002 parts, Offset 092 Flags 066 Comp 000 Sparse *. Pos 000000156 Len 000000008 Pos 000000164 Len 000000008 Loading sample file 'myextisam' @@ -10997,7 +10997,7 @@ AT_DATA([prog.cob], [ MOVE 5 TO FCD-MAX-REC-LENGTH. CALL "EXTFH" USING OPCODE, FCD. DISPLAY "OPEN STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY. + FCD-FILE-STATUS. * READ RECORD MOVE OP-READ-NEXT TO OPCODE. @@ -11006,7 +11006,7 @@ AT_DATA([prog.cob], [ MOVE SPACE TO EX-RECORD-BUFFER CALL "EXTFH" USING OPCODE, FCD DISPLAY "READ NEXT STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY + FCD-FILE-STATUS DISPLAY "DATA:" EX-RECORD-BUFFER(1:10) '-' END-PERFORM. @@ -11014,7 +11014,7 @@ AT_DATA([prog.cob], [ MOVE OP-CLOSE TO OPCODE. CALL "EXTFH" USING OPCODE, FCD. DISPLAY "CLOSE STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY. + FCD-FILE-STATUS. * OPEN second file MOVE fcd--line-sequential-org TO FCD-ORGANIZATION. @@ -11026,7 +11026,7 @@ AT_DATA([prog.cob], [ MOVE 10 TO FCD-MAX-REC-LENGTH. CALL "EXTFH" USING OPCODE, FCD. DISPLAY "OPEN STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY. + FCD-FILE-STATUS. * READ RECORD MOVE OP-READ-NEXT TO OPCODE. @@ -11035,7 +11035,7 @@ AT_DATA([prog.cob], [ MOVE SPACE TO EX-RECORD-BUFFER CALL "EXTFH" USING OPCODE, FCD DISPLAY "READ NEXT STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY + FCD-FILE-STATUS DISPLAY "DATA:" EX-RECORD-BUFFER(1:10) '-' END-PERFORM. @@ -11043,7 +11043,7 @@ AT_DATA([prog.cob], [ MOVE OP-CLOSE TO OPCODE. CALL "EXTFH" USING OPCODE, FCD. DISPLAY "CLOSE STATUS:" - FCD-STATUS-KEY-1 "/" FCD-BINARY. + FCD-FILE-STATUS. MAIN-EXT. STOP RUN. @@ -11052,32 +11052,32 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], -[OPEN STATUS:0/48 -READ NEXT STATUS:0/48 +[OPEN STATUS:00 +READ NEXT STATUS:00 DATA:SEQ01 - -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:SEQ02 - -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:SEQ03 - -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:SEQ04 - -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:SEQ05 - -READ NEXT STATUS:1/48 +READ NEXT STATUS:10 DATA: - -CLOSE STATUS:0/48 -OPEN STATUS:0/48 -READ NEXT STATUS:0/48 +CLOSE STATUS:00 +OPEN STATUS:00 +READ NEXT STATUS:00 DATA:TXTA123456- -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:TXTB123456- -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:TXTC123456- -READ NEXT STATUS:0/48 +READ NEXT STATUS:00 DATA:TXTD123456- -READ NEXT STATUS:1/48 +READ NEXT STATUS:10 DATA: - -CLOSE STATUS:0/48 +CLOSE STATUS:00 ], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 69dfde687..dcfd80ea0 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -10664,7 +10664,7 @@ WORKING-STORAGE ********************** 77 RETURN-CODE +000000000 01 ZRO 000000000 -01 HEXV 13 +01 HEXV 013 01 TEST-BASED. address 01 TEST-ALLOCED. 05 TEST-ALLOCED-SUB1 ALL SPACES @@ -10728,7 +10728,7 @@ WORKING-STORAGE ********************** 77 RETURN-CODE +000000000 01 ZRO 000000000 -01 HEXV 13 +01 HEXV 013 01 IDX 000000000 01 TSTREC. 05 TSTDEP 'XXX' @@ -15201,8 +15201,8 @@ AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./caller], [0 [File prof.csv generated ]) -AT_CLEANUP +AT_CLEANUP AT_SETUP([MOVE to NUMERIC-EDITED safety]) @@ -15251,3 +15251,81 @@ AT_CHECK([$COMPILE prog.cob]) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [1.2345E-5 1.2345E-5], []) AT_CLEANUP + + +AT_SETUP([PICTURE COMP-X]) +AT_KEYWORDS([Numeric]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TST. + 05 BVAL PIC 9999 BINARY VALUE 512. + 05 XVAL PIC XX COMP-X VALUE 512. + 88 XLOW VALUE 0 THRU 256. + 88 XHIGH VALUE 257 THRU 65536. + 05 VAL9 PIC 99999 COMP-X VALUE 1024. + 88 LOW9 VALUE 0 THRU 256. + 88 HIGH9 VALUE 257 THRU 65536. + 05 XVAL2 PIC XX COMP-X VALUE 16706. + 05 XVALX REDEFINES XVAL2 PIC XX. + 05 YVALX PIC XX VALUE 'A '. + 05 YVAL2 REDEFINES YVALX PIC XX COMP-X. + + PROCEDURE DIVISION. + DISPLAY " XVAL is " XVAL "; Length is " LENGTH OF XVAL. + DISPLAY " VAL9 is " VAL9 "; Length is " LENGTH OF VAL9. + MOVE 10240 TO XVAL. + DISPLAY " XVAL is " XVAL "; Length is " LENGTH OF XVAL. + DISPLAY "XVAL2 is " XVAL2 "; Length is " LENGTH OF XVAL2. + DISPLAY "XVALX is " XVALX "; Length is " LENGTH OF XVALX. + ADD 1 TO XVAL2. + DISPLAY "XVALX is " XVALX " after +1;". + COMPUTE XVAL2 = XVAL2 / 256 + 8192. + DISPLAY "XVALX is " XVALX " after / 256 + 8192;". + MOVE 'DE' TO XVALX. + DISPLAY "Numeric: " XVAL2 " is char " XVALX. + MOVE ZERO TO YVAL2. + MOVE 'D' TO YVALX (1:1) + MOVE LOW-VALUES TO YVALX (2:1) + SUBTRACT YVAL2 FROM XVAL2. + MOVE ' ' TO YVALX (1:1) + MOVE LOW-VALUES TO YVALX (2:1) + ADD YVAL2 TO XVAL2. + DISPLAY "Numeric: " XVAL2 " is char " XVALX. + MOVE 0 TO XVAL. + ADD 10240 TO XVAL. + IF XVAL = 10240 + DISPLAY "XVAL is " XVAL + ELSE + DISPLAY "XVAL is not 10240 but " XVAL + END-IF. + MOVE 0 TO BVAL. + ADD 10240 TO BVAL. + IF BVAL = 0240 + DISPLAY "BVAL is " BVAL + ELSE + DISPLAY "BVAL is not 0240 but " BVAL + END-IF. + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +AT_CHECK([./prog], [0], [ XVAL is 00512; Length is 2 + VAL9 is 01024; Length is 3 + XVAL is 10240; Length is 2 +XVAL2 is 16706; Length is 2 +XVALX is AB; Length is 2 +XVALX is AC after +1; +XVALX is A after / 256 + 8192; +Numeric: 17477 is char DE +Numeric: 08261 is char E +XVAL is 10240 +BVAL is 0240 +], []) + +AT_CLEANUP +