}
return true;
}
- bool vet() const { // be always agreeable, for now.
+ bool vet() const { // be always agreeable, for now.
return dangling.empty();
}
void dump() const {
fprintf(stderr, "%u nonexistent labels called\n", unsigned(dangling.size()) );
for( auto sym : dangling ) {
- auto label = cbl_label_of(symbol_at(sym));
+ const cbl_label_t *label = cbl_label_of(symbol_at(sym));
fprintf(stderr, "\t %s\n", label->name);
}
}
} label_verify;
-
+
void
parser_end_program(const char *prog_name )
{
case custom_encoding_e:
{
+#pragma message "Use program-id to disambiguate"
size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet));
unsigned char ach[256];
gg_assign( gg_array_value(table256, ch),
build_int_cst_type(UCHAR, (alphabet.alphabet[i])) );
}
+
+ unsigned int low_char = alphabet.low_char;
+ unsigned int high_char = alphabet.high_char;
__gg__alphabet_create(alphabet.encoding,
alphabet_index,
ach,
- alphabet.low_index,
- alphabet.high_index);
+ low_char,
+ high_char);
gg_call(VOID,
"__gg__alphabet_create",
build_int_cst_type(INT, alphabet.encoding),
build_int_cst_type(SIZE_T, alphabet_index),
gg_get_address_of(table256),
- build_int_cst_type(INT, alphabet.low_index),
- build_int_cst_type(INT, alphabet.high_index),
-
+ build_int_cst_type(INT, low_char),
+ build_int_cst_type(INT, high_char),
NULL_TREE );
break;
}
default:
fprintf(stderr, "%s: Program ID %s:\n",
- cobol_filename(),
+ cobol_filename(),
cbl_label_of(symbol_at(current_program_index()))->name);
gcc_unreachable();
}
__gg__high_value_character = DEGENERATE_HIGH_VALUE;
gg_call(VOID,
"__gg__alphabet_use",
- build_int_cst_type(INT, current_encoding(encoding_display_e)),
+ build_int_cst_type(INT, current_encoding(display_encoding_e)),
+ build_int_cst_type(INT, current_encoding(national_encoding_e)),
build_int_cst_type(INT, alphabet.encoding),
null_pointer_node,
NULL_TREE);
gg_call(VOID,
"__gg__alphabet_use",
- build_int_cst_type(INT, current_encoding(encoding_display_e)),
+ build_int_cst_type(INT, current_encoding(display_encoding_e)),
+ build_int_cst_type(INT, current_encoding(national_encoding_e)),
build_int_cst_type(INT, alphabet.encoding),
build_int_cst_type(SIZE_T, alphabet_index),
NULL_TREE);
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_LABEL("", instance)
+ SHOW_PARSE_LABEL_OK("", instance)
SHOW_PARSE_REF(" ", input)
SHOW_PARSE_END
}
// We need to create a COBOL ENTRY point into this function. That entry
// point will be used by __gg__xml_parse to perform from_proc through to_proc
// as part of processing the libxml2 callbacks.
-
+
char ach[64];
static int instance_counter = 1;
sprintf(ach,
gg_get_address_of(input.field->var_decl_node),
refer_offset(input),
refer_size_source(input),
- encoding ?
+ encoding ?
gg_get_address_of(encoding->var_decl_node)
: null_pointer_node,
- validating ?
+ validating ?
gg_get_address_of(validating->var_decl_node)
: null_pointer_node,
build_int_cst_type(INT, returns_national),
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_LABEL(" ", instance)
+ SHOW_PARSE_LABEL_OK(" ", instance)
SHOW_PARSE_END
}
gg_append_statement(instance->structs.xml_parse->over.go_to);
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_LABEL(" ", instance)
+ SHOW_PARSE_LABEL_OK(" ", instance)
SHOW_PARSE_END
}
gg_append_statement(instance->structs.xml_parse->over.go_to);
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_LABEL(" ", instance)
+ SHOW_PARSE_LABEL_OK(" ", instance)
SHOW_PARSE_END
}
gg_append_statement(instance->structs.xml_parse->over.label);
// This is one-time initialization of the libgcobol program state stack
gg_call(VOID,
"__gg__init_program_state",
- build_int_cst_type(INT, current_encoding(encoding_display_e)),
+ build_int_cst_type(INT, current_encoding(display_encoding_e)),
+ build_int_cst_type(INT, current_encoding(national_encoding_e)),
NULL_TREE);
__gg__currency_signs = __gg__ct_currency_signs;
CHECK_LABEL(label);
+#if 1
+ // At the present time, label_verify.lay is returning true, so I edited
+ // out the if( !... ) to quiet cppcheck
+ label_verify.lay(label);
+#else
if( ! label_verify.lay(label) )
{
yywarn("%s: label %qs already exists", __func__, label->name);
gcc_unreachable();
}
+#endif
if(strcmp(label->name, "_end_declaratives") == 0 )
{
label_verify.go_to(label);
+ label_verify.go_to(label);
+
if( strcmp(label->name, "_end_declaratives") == 0 )
{
suppress_cobol_entry_point = true;
__func__);
}
+#pragma message "Use program-id to disambiguate"
size_t symbol_table_index = symbol_index(symbol_elem_of(file));
gg_call(VOID,
/* Right now, file->codeset.encoding is not being set properly. Remove this
comment and fix the following code when that's repaired. */
// build_int_cst_type(INT, (int)file->codeset.encoding),
- build_int_cst_type(INT, current_encoding(encoding_display_e)),
+ build_int_cst_type(INT, current_encoding(display_encoding_e)),
build_int_cst_type(INT, (int)file->codeset.alphabet),
NULL_TREE);
file->var_decl_node = new_var_decl;
}
}
}
+ else if( strcmp(function_name, "__gg__char") == 0 )
+ {
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ gg_get_address_of(ref1.field->var_decl_node),
+ refer_offset(ref1),
+ refer_size_source(ref1),
+ NULL_TREE);
+ }
else
{
TRACE1
TRACE1_REFER("parameter 2: ", ref2, "")
}
store_location_stuff(function_name);
+
gg_call(VOID,
function_name,
gg_get_address_of(tgt->var_decl_node),
gg_get_address_of(ref1.field->var_decl_node),
refer_offset(ref1),
refer_size_source(ref1),
- ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
+ ref2.field ? gg_get_address_of(ref2.field->var_decl_node)
+ : null_pointer_node,
refer_offset(ref2),
refer_size_source(ref2),
NULL_TREE);
| ORD '(' alpha_val[r1] ')'
{
location_set(@1);
- $$ = new_tempnumeric("ORD");
+ $$ = new_tempnumeric("ORD", none_e);
if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR;
}
| RANDOM
const unsigned char * const pend = alphabet + sizeof(alphabet);
std::vector<char> tgt(256, (char)0xFF);
+ /* Keep copies of low_index and last_index for use in run-time as LOW-VALUE
+ and HIGH-VALUE, which are kept as globals in the source-code codeset
+ and converted to the display encoding as necessary. */
+
+ low_char = low_index;
+ high_char = last_index;
+
/*
* For now, assume CP1252 source-code encoding because we're not capturing it
* anywhere except in cbl_field_t::internalize(). The only known examples of
// current_encoding('A') and current_encoding('N')
enum
{
- encoding_display_e = 'A',
- encoding_national_e = 'N'
+ display_encoding_e = 'A',
+ national_encoding_e = 'N'
};
cbl_encoding_t current_encoding( char a_or_n );
cbl_name_t name;
cbl_encoding_t encoding;
unsigned char low_index, high_index, last_index, alphabet[256];
+ unsigned char low_char, high_char;
cbl_alphabet_t()
: loc { 1,1, 1,1 }
, low_index(0)
, high_index(255)
, last_index(0)
+ , low_char(0)
+ , high_char(0)
{
memset(name, '\0', sizeof(name));
memset(alphabet, 0xFF, sizeof(alphabet));
, low_index(0)
, high_index(255)
, last_index(0)
+ , low_char(0)
+ , high_char(0)
{
memset(name, '\0', sizeof(name));
memset(alphabet, 0xFF, sizeof(alphabet));
, encoding(custom_encoding_e)
, low_index(low_index), high_index(high_index)
, last_index(high_index)
+ , low_char(low_index)
+ , high_char(high_index)
{
assert(strlen(name) < sizeof(this->name));
strcpy(this->name, name);
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CALL_with_OCCURS_DEPENDING_ON.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog-main.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 parm.
+ 03 parm-size PIC S999 COMP.
+ 03 parm-str.
+ 05 parm-char PIC X OCCURS 0 TO 100 TIMES
+ DEPENDING ON parm-size.
+
+ PROCEDURE DIVISION.
+ MOVE 10 TO parm-size
+ MOVE "Hi, there!" TO parm-str
+ CALL "prog" USING parm
+ .
+ END PROGRAM prog-main.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 parm.
+ 03 parm-size PIC S999 COMP.
+ 03 parm-str.
+ 05 parm-char PIC X OCCURS 0 TO 100 TIMES
+ DEPENDING ON parm-size.
+
+ PROCEDURE DIVISION USING parm.
+ DISPLAY FUNCTION TRIM(parm-str) WITH NO ADVANCING
+ .
+ END PROGRAM prog.
+
--- /dev/null
+Hi, there!
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ OBJECT-COMPUTER.
+ GNU-Linux
+ PROGRAM COLLATING SEQUENCE IS THE-WILD-ONE.
+ SPECIAL-NAMES.
+ ALPHABET
+ THE-WILD-ONE IS "A" THRU "H" "I" ALSO "J", ALSO "K", ALSO
+ "L" ALSO "M" ALSO "N" "O" THROUGH "Z" "0" THRU "9".
+ PROCEDURE DIVISION.
+ DISPLAY LOW-VALUE
+ DISPLAY HIGH-VALUE
+ DISPLAY FUNCTION CHAR(1).
+ DISPLAY FUNCTION CHAR(9).
+ DISPLAY FUNCTION CHAR(10).
+ DISPLAY FUNCTION ORD("A")
+ DISPLAY FUNCTION ORD("I")
+ DISPLAY FUNCTION ORD("J")
+ DISPLAY FUNCTION ORD("K")
+ DISPLAY FUNCTION ORD("O")
+ GOBACK.
+
--- /dev/null
+A
+9
+A
+I
+O
+1
+9
+9
+9
+10
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-finternal-ebcdic" }
+ *> { dg-output-file "group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ OBJECT-COMPUTER.
+ GNU-Linux
+ PROGRAM COLLATING SEQUENCE IS THE-WILD-ONE.
+ SPECIAL-NAMES.
+ ALPHABET
+ THE-WILD-ONE IS "A" THRU "H" "I" ALSO "J", ALSO "K", ALSO
+ "L" ALSO "M" ALSO "N" "O" THROUGH "Z" "0" THRU "9".
+ PROCEDURE DIVISION.
+ DISPLAY LOW-VALUE
+ DISPLAY HIGH-VALUE
+ DISPLAY FUNCTION CHAR(1).
+ DISPLAY FUNCTION CHAR(9).
+ DISPLAY FUNCTION CHAR(10).
+ DISPLAY FUNCTION ORD("A")
+ DISPLAY FUNCTION ORD("I")
+ DISPLAY FUNCTION ORD("J")
+ DISPLAY FUNCTION ORD("K")
+ DISPLAY FUNCTION ORD("O")
+ GOBACK.
+
--- /dev/null
+A
+9
+A
+I
+O
+1
+9
+9
+9
+10
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-xfail-run-if "" { *-*-* } }
+ *> { dg-output-file "group2/EC-BOUND-REF-MOD_checking_process_termination.out" }
+ identification division.
+ program-id. caller.
+ data division.
+ working-storage section.
+ 77 str pic x(4) value "abcd".
+ procedure division.
+ display "sending str " str
+ call "prog1" using str.
+ display "returned str " str
+ call "prog2" using str.
+ display "returned str " str
+ goback.
+
+ identification division.
+ program-id. prog1.
+ data division.
+ linkage section.
+ 01 str pic x any length.
+ procedure division using str.
+ move '4' to str(5:1)
+ display "We should get here, because there is no checking"
+ goback.
+ end program prog1.
+
+ >>turn ec-all checking on
+ identification division.
+ program-id. prog2.
+ data division.
+ linkage section.
+ 01 str pic x any length.
+ procedure division using str.
+ move '4' to str(5:1)
+ display "I don't think we should get here?"
+ goback.
+ end program prog2.
+
+ end program caller.
+
--- /dev/null
+sending str abcd
+We should get here, because there is no checking
+returned str abcd
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION PI INTRINSIC
+ FUNCTION E INTRINSIC.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 Z PIC 99V99.
+ PROCEDURE DIVISION.
+ MOVE PI TO Z.
+ MOVE E TO Z.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Occurs_DEPENDING_ON__source_and_dest.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 table1d value "1234567890".
+ 02 table1 pic x occurs 0 to 10 times depending on table1do.
+
+ 01 table2d value "1234567890".
+ 02 table2 pic x occurs 0 to 10 times depending on table2do.
+
+ 01 table3d.
+ 02 table3do pic 99.
+ 02 table3dd.
+ 03 table3 pic x occurs 0 to 10 times depending on table3do.
+
+ 77 table1do pic 99.
+ 77 table2do pic 99.
+ 77 n pic 99.
+ procedure division.
+ display "Test1: Demonstrate ODO limits:"
+ perform varying n from 0 by 1 until n > 10
+ move n to table1do
+ display n space """"table1d""""
+ end-perform
+
+ display "Test2: result should be ABC4567890"
+ move 3 to table2do
+ move "ABCDEFGHIJ" to table2d
+ move 10 to table2do
+ display " result is "table2d
+
+ display "Test3A: result should be 05ABCDE"
+ move "05ABCDEFGHIJ" to table3d
+ display " result is "table3d
+ move 10 to table3do
+ display "Test3B: result should be 10ABCDEFGHIJ"
+ display " result is "table3d
+
+ display "Test4: result should be 10lmnopqGHIJ"
+ move 6 to table3do
+ move "lmnopqrstu" to table3dd
+ move 10 to table3do
+ display " result is "table3d
+
+ goback.
+
--- /dev/null
+Test1: Demonstrate ODO limits:
+00 ""
+01 "1"
+02 "12"
+03 "123"
+04 "1234"
+05 "12345"
+06 "123456"
+07 "1234567"
+08 "12345678"
+09 "123456789"
+10 "1234567890"
+Test2: result should be ABC4567890
+ result is ABC4567890
+Test3A: result should be 05ABCDE
+ result is 05ABCDE
+Test3B: result should be 10ABCDEFGHIJ
+ result is 10ABCDEFGHIJ
+Test4: result should be 10lmnopqGHIJ
+ result is 10lmnopqGHIJ
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Recursive_subscripts.out" }
+
+ identification division.
+ program-id. pmain.
+ data division.
+ working-storage section.
+ 01 filler.
+ 02 tabl-values pic x(9) value "234567890".
+ 02 v redefines tabl-values occurs 9 pic 9.
+ procedure division.
+ display v(1) " should be 2"
+ display v(v(1)) " should be 3"
+ display v(v(v(1))) " should be 4"
+ display v(v(v(v(1)))) " should be 5"
+ display v(v(v(v(v(1))))) " should be 6"
+ display v(v(v(v(v(v(1)))))) " should be 7"
+ display v(v(v(v(v(v(v(1))))))) " should be 8"
+ display v(v(v(v(v(v(v(v(1)))))))) " should be 9"
+
+ display v(v(v(v(v(v(v(v(v(1))))))))) " should be 0"
+ move 1 to v(v(v(v(v(v(v(v(v(1)))))))))
+ display v(v(v(v(v(v(v(v(v(1))))))))) " should be 1"
+
+ goback.
+ end program pmain.
+
--- /dev/null
+2 should be 2
+3 should be 3
+4 should be 4
+5 should be 5
+6 should be 6
+7 should be 7
+8 should be 8
+9 should be 9
+0 should be 0
+1 should be 1
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ *
+ 77 SCREEN-AKT PIC 9(02) VALUE 0.
+ 01 SCREEN-TAB.
+ 03 SCREEN-ENTRY OCCURS 0 TO 20
+ DEPENDING ON SCREEN-AKT
+ ASCENDING KEY SCREEN-NAME
+ INDEXED BY SCREEN-IDX.
+ 05 SCREEN-NAME PIC X(02).
+
+ PROCEDURE DIVISION.
+
+ SEARCH ALL SCREEN-ENTRY
+ AT END
+ DISPLAY 'END'
+ WHEN SCREEN-NAME (SCREEN-IDX) = 'AB'
+ DISPLAY 'FOUND'
+ END-SEARCH
+ MOVE 1 TO SCREEN-AKT
+ MOVE 'AB' TO SCREEN-NAME (1)
+ SEARCH ALL SCREEN-ENTRY
+ AT END
+ DISPLAY 'END'
+ WHEN SCREEN-NAME (SCREEN-IDX) = 'AB'
+ DISPLAY 'FOUND'
+ END-SEARCH
+ MOVE 2 TO SCREEN-AKT
+ MOVE 'CD' TO SCREEN-NAME (2)
+ SEARCH ALL SCREEN-ENTRY
+ AT END
+ DISPLAY 'END'
+ WHEN SCREEN-NAME (SCREEN-IDX) = 'CD'
+ DISPLAY 'FOUND'
+ END-SEARCH
+ EXIT PROGRAM.
+
--- /dev/null
+END
+FOUND
+FOUND
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G VALUE "1234".
+ 02 X PIC X OCCURS 4.
+ 01 Z PIC X.
+ PROCEDURE DIVISION.
+ MOVE X((3 + 1) / 2) TO Z.
+ IF Z NOT = "2"
+ DISPLAY Z
+ END-DISPLAY
+ END-IF.
+ MOVE X(2 ** 2) TO Z.
+ IF Z NOT = "4"
+ DISPLAY Z
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-xfail-run-if "" { *-*-* } }
+ *> { dg-output-file "group2/Subscript_out_of_bounds__1_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G.
+ 02 X PIC X OCCURS 10.
+ 01 I PIC 9 VALUE 0.
+ PROCEDURE DIVISION.
+ >>TURN EC-ALL CHECKING ON
+ DISPLAY """" X(I) """"
+ END-DISPLAY.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-xfail-run-if "" { *-*-* } }
+ *> { dg-output-file "group2/Subscript_out_of_bounds__2_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G.
+ 02 X PIC X OCCURS 10.
+ 01 I PIC 99 VALUE 11.
+ PROCEDURE DIVISION.
+ >>TURN EC-ALL CHECKING ON
+ DISPLAY """" X(I) """"
+ END-DISPLAY.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Subscripted_refmods.out" }
+
+ identification division.
+ program-id. pmain.
+ data division.
+ working-storage section.
+ 01 filler.
+ 02 tabl-values pic x(9) value "123456789".
+ 02 v redefines tabl-values occurs 9 pic 9.
+ procedure division.
+ display tabl-values( 3:4 ) " should be 3456"
+ display tabl-values( v(3):v(4) ) " should be 3456"
+ goback.
+ end program pmain.
+
--- /dev/null
+3456 should be 3456
+3456 should be 3456
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/length_of_ODO_Rules_7__8A__and_8B.out" }
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ call "prog1"
+ call "prog2"
+ call "prog3"
+ goback.
+ end program prog.
+
+ identification division.
+ program-id. prog1.
+ data division.
+ working-storage section.
+ 01 depl pic 9.
+ 01 digtab.
+ 05 digitgrp.
+ 10 digits occurs 1 to 9 depending on depl pic x.
+ procedure division.
+ display "Demonstrates 13.18.38.4 OCCURS General rules 7)"
+ display "depl is completely separate"
+ display "output should be ""12345 """
+ move 9 to depl
+ move space to digtab
+ move 5 to depl
+ move "123456789" to digtab
+ move 9 to depl
+ display """" digtab """"
+ goback.
+ end program prog1.
+
+ identification division.
+ program-id. prog2.
+ data division.
+ working-storage section.
+ 01 digtab.
+ 05 depl pic 9.
+ 05 digitgrp.
+ 10 digits occurs 1 to 9 depending on depl pic x.
+ procedure division.
+ display "Demonstrates 13.18.38.4 OCCURS General rules 8a)"
+ display "depl is not subordinate to digitgrp"
+ display "output should be ""12345 """
+ move 9 to depl
+ move space to digtab
+ move 5 to depl
+ move "123456789" to digitgrp
+ move 9 to depl
+ display """" digitgrp """"
+ goback.
+ end program prog2.
+
+ identification division.
+ program-id. prog3.
+ data division.
+ working-storage section.
+ 01 digtab.
+ 05 depl pic 9.
+ 05 digitgrp.
+ 10 digits occurs 1 to 9 depending on depl pic x.
+ procedure division.
+ display "Demonstrates 13.18.38.4 OCCURS General rules 8b)"
+ display "depl is subordinate to digtab"
+ display "output should be ""123"" followed by ""123456789"""
+ move 9 to depl
+ move space to digtab
+ move 5 to depl
+ move "3123456789" to digtab
+ display """" digitgrp """"
+ move 9 to depl
+ display """" digitgrp """"
+ goback.
+ end program prog3.
+
--- /dev/null
+Demonstrates 13.18.38.4 OCCURS General rules 7)
+depl is completely separate
+output should be "12345 "
+"12345 "
+Demonstrates 13.18.38.4 OCCURS General rules 8a)
+depl is not subordinate to digitgrp
+output should be "12345 "
+"12345 "
+Demonstrates 13.18.38.4 OCCURS General rules 8b)
+depl is subordinate to digtab
+output should be "123" followed by "123456789"
+"123"
+"123456789"
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 PLINE.
+ 03 PLINE-LEN PIC S9(4) COMP-5.
+ 03 PLINE-TEXT.
+ 04 FILLER PIC X(1) OCCURS 1 TO 80
+ DEPENDING ON PLINE-LEN.
+ procedure division.
+ a-main section.
+ MOVE 5 TO PLINE-LEN
+ MOVE 'the first part in' TO PLINE-TEXT
+ MOVE 30 TO PLINE-LEN
+ IF PLINE-TEXT NOT = 'the f'
+ DISPLAY 'text1 wrong: ' PLINE-TEXT
+ END-DISPLAY
+ END-IF
+ MOVE 'the first part in' TO PLINE-TEXT
+ MOVE 4 TO PLINE-LEN
+ MOVE 'second' TO PLINE-TEXT
+ MOVE 14 TO PLINE-LEN
+ IF PLINE-TEXT NOT = 'secofirst part'
+ DISPLAY 'text2 wrong: ' PLINE-TEXT
+ END-DISPLAY
+ END-IF
+ MOVE 80 TO PLINE-LEN
+ MOVE SPACES TO PLINE-TEXT
+ MOVE 5 TO PLINE-LEN
+ MOVE 'the first part in' TO PLINE-TEXT (2:)
+ MOVE 30 TO PLINE-LEN
+ IF PLINE-TEXT NOT = ' the '
+ DISPLAY 'text3 wrong: ' PLINE-TEXT
+ END-DISPLAY
+ END-IF
+ MOVE 'the first part in' TO PLINE-TEXT (2:)
+ MOVE 4 TO PLINE-LEN
+ MOVE 'second' TO PLINE-TEXT (2:)
+ MOVE 14 TO PLINE-LEN
+ IF PLINE-TEXT NOT = ' sec first par'
+ DISPLAY 'text4 wrong: ' PLINE-TEXT
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+
int __gg__low_value_character = 0x00 ;
int __gg__high_value_character = 0xFF ;
char **__gg__currency_signs ;
-
int __gg__default_currency_sign;
-
char *__gg__ct_currency_signs[256]; // Compile-time currency signs
+cbl_encoding_t __gg__display_encoding = no_encoding_e;
+cbl_encoding_t __gg__national_encoding = no_encoding_e;
// First: single-byte-coded (SBC) character sets:
extern int __gg__high_value_character ;
extern char **__gg__currency_signs ;
extern int __gg__default_currency_sign;
+extern cbl_encoding_t __gg__display_encoding ;
+extern cbl_encoding_t __gg__national_encoding ;
extern char *__gg__ct_currency_signs[256]; // Compile-time currency signs
#define NULLCH ('\0')
}
int low_value_character()
{
- return __gg__low_value_character;
+ return mapped_character(__gg__low_value_character);
}
int high_value_character()
{
- return __gg__high_value_character;
+ return mapped_character(__gg__high_value_character);
}
int figconst_character(cbl_figconst_t figconst)
// The CHAR function takes an integer, the ordinal position. It
// returns a single-character string, which is the character at that
- // ordinal position.
+ // ordinal position in the DISPLAY collation.
- // 'A', with the ascii value of 65, is at the ordinal position 66.
+ // 'A', with the ascii value of 65, is at the ordinal position 66
+ // in the default collation.
int ordinal = (int)(__gg__binary_value_from_qualified_field(&rdigits,
source,
source_offset,
source_size));
ordinal /= __gg__power_of_ten(rdigits);
- int ch = ordinal-1;
- charmap_t *charmap = __gg__get_charmap(dest->encoding);
- memset(dest->data, charmap->mapped_character(ascii_space), dest->capacity);
- dest->data[0] = ch;
+ ordinal -= 1;
+
+ // We now look for that ordinal position in the collation table:
+ const unsigned short *collation = __gg__current_collation();
+ int ch = -1;
+ for(int i=0; i<256; i++)
+ {
+ if( collation[i] == ordinal )
+ {
+ ch = i;
+ break;
+ }
+ }
+ if( ch == -1 )
+ {
+ // This means that the given ordinal was not in the range of
+ // LOW-VALUE through HIGH-VALUE
+ exception_raise(ec_argument_function_e);
+ }
+
+ // We need to convert the ch character to the destination encoding.
+ const char achFrom[2] = {static_cast<char>(ch), '\0'};
+ size_t charsout;
+ const char *converted = __gg__iconverter(__gg__display_encoding,
+ dest->encoding,
+ achFrom,
+ 1,
+ &charsout );
+ // Pick up our character, because mapped_character() might clobber
+ // the converted contents.
+ int converted_char = *converted; // cppcheck-suppress variableScope
+ // Space fill the dest:
+ charmap_t *charmap_dest = __gg__get_charmap(dest->encoding);
+ memset(dest->data,
+ charmap_dest->mapped_character(ascii_space),
+ dest->capacity);
+ // Make the first character of the destination equal to our converted
+ // character:
+ if( ch > -1 && charsout == 1 )
+ {
+ dest->data[0] = converted_char;
+ }
}
extern "C"
const char *arg = PTRCAST(char, (input->data + input_offset));
// The ORD function takes a single-character string and returns the
- // ordinal position of that character.
+ // ordinal position of that character within the current collation.
+
+ const unsigned short *collation = __gg__current_collation();
+
+ size_t retval = (collation[arg[0]&0xFF]) + 1;
- size_t retval = (arg[0]&0xFF) + 1;
__gg__int128_to_field(dest,
retval,
NO_RDIGITS,
int rt_high_value_character;
char *rt_currency_signs[256];
const unsigned short *rt_collation; // Points to a table of 256 values;
+ cbl_encoding_t rt_display_encoding;
+ cbl_encoding_t rt_national_encoding;
char *rt_program_name;
program_state()
memset(rt_currency_signs, 0, sizeof(rt_currency_signs));
+ rt_display_encoding = __gg__display_encoding;
+ rt_national_encoding = __gg__national_encoding;
rt_collation = __gg__one_to_one_values;
rt_program_name = NULL;
}
rt_quote_character = ps.rt_quote_character ;
rt_low_value_character = ps.rt_low_value_character ;
// Note throughout the code that there is special processing for the
- // high-value character. In EBCDIC 0xFF doesn't map to ASCII 0xFF, so
- // we are forced to avoid converting EBCDIC 0xFF.
+ // default high-value character. In EBCDIC 0xFF doesn't map
+ // to ASCII 0xFF, so we are forced to avoid converting EBCDIC 0xFF.
rt_high_value_character = ps.rt_high_value_character ;
- rt_collation = ps.rt_collation ;
+ rt_display_encoding = ps.rt_display_encoding ;
+ rt_national_encoding = ps.rt_national_encoding ;
+ rt_collation = ps.rt_collation ;
for( int i=0; i<256; i++ )
{
static std::vector<program_state> program_states;
#define collated(a) (program_states.back().rt_collation[(unsigned int)(a&0xFF)])
#define program_name (program_states.back().rt_program_name)
-// #define decimal_point (program_states.back().rt_decimal_point)
-// #define decimal_separator (program_states.back().rt_decimal_separator)
-// #define quote_character (program_states.back().rt_quote_character)
-// #define low_value_character (program_states.back().rt_low_value_character)
-// #define high_value_character (program_states.back().rt_high_value_character)
-// #define currency_signs(a) (program_states.back().rt_currency_signs[(a)])
#define currency_signs(a) (__gg__currency_signs[(a)])
+const unsigned short *
+__gg__current_collation()
+ {
+ return program_states.back().rt_collation;
+ }
+
#ifdef DEBUG_MALLOC
void *malloc(size_t a)
{
__gg__quote_character = program_states.back().rt_quote_character ;
__gg__low_value_character = program_states.back().rt_low_value_character ;
__gg__high_value_character = program_states.back().rt_high_value_character ;
+ __gg__display_encoding = program_states.back().rt_display_encoding ;
+ __gg__national_encoding = program_states.back().rt_national_encoding ;
__gg__currency_signs = program_states.back().rt_currency_signs ;
}
extern "C"
void
-__gg__init_program_state()
+__gg__init_program_state(cbl_encoding_t display_encoding,
+ cbl_encoding_t national_encoding)
{
// This routine gets called at DATA DIVISION time.
+ __gg__display_encoding = display_encoding;
+ __gg__national_encoding = national_encoding;
+
// We need to make sure that the program_states vector has at least one
// entry in it. This happens when we are the very first PROGRAM-ID called
// in this module.
case FldAlphanumeric:
case FldNumericEdited:
case FldAlphaEdited:
+ {
__gg__realloc_if_necessary(dest, dest_size, actual_length+1);
- if( actual_location )
+
+ cbl_figconst_t figconst = (cbl_figconst_t)(var->attr & FIGCONST_MASK);
+ if( figconst )
{
- memcpy(*dest, actual_location, actual_length);
+ charmap_t *charmap = __gg__get_charmap(retval);
+ int figconst_char = charmap->figconst_character(figconst);
+ memset(*dest, figconst_char, actual_length);
+ (*dest)[actual_length] = NULLCH;
}
else
{
- fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name);
- abort();
+ if( actual_location )
+ {
+ memcpy(*dest, actual_location, actual_length);
+ }
+ else
+ {
+ fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name);
+ abort();
+ }
+ (*dest)[actual_length] = NULLCH;
}
- (*dest)[actual_length] = NULLCH;
break;
+ }
case FldNumericDisplay:
{
unsigned int fig_left = 0;
unsigned int fig_right = 0;
+
fig_left = charmap_left->figconst_character(left_figconst);
fig_right = charmap_right->figconst_character(right_figconst);
extern "C"
void
-__gg__alphabet_use( cbl_encoding_t alphabetic_encoding,
+__gg__alphabet_use( cbl_encoding_t display_encoding,
+ cbl_encoding_t national_encoding,
cbl_encoding_t encoding,
size_t alphabet_index)
{
// state needs to be saved -- for example, if we are doing a SORT with an
// ALPHABET override -- that's up to the caller
+ __gg__display_encoding = display_encoding;
+ __gg__national_encoding = national_encoding;
+
if( program_states.empty() )
{
// When there is no DATA DIVISION, program_states can be empty when
initialize_program_state();
}
- const charmap_t *charmap_alphabetic = __gg__get_charmap(alphabetic_encoding);
+ const charmap_t *charmap_alphabetic = __gg__get_charmap(display_encoding);
switch( encoding )
{
cbl_encoding_t from,
cbl_encoding_t to );
+const unsigned short *__gg__current_collation();
+
#endif
extern "C"
int
-__gg__xml_parse( cblc_field_t *input_field,
+__gg__xml_parse( const cblc_field_t *input_field,
size_t input_offset,
size_t len,
cblc_field_t *encoding,
int returns_national,
void (*callback)(void) )
{
- extern struct cblc_field_t __ggsr__xml_code;
-
initialize_handlers(callback);
const char *input = PTRCAST(char, input_field->data + input_offset);
projects / thirdparty / gcc.git / commitdiff
