diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index 985b3a52d51..dbd001740dd 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -63,23 +63,9 @@ extern tree var_decl_entry_index; // void*
__gg__entry_index
extern tree var_decl_dialects; // void* __gg__dialects
extern tree var_decl_dp2bin; // unsigned char * ___gg__dp2bin
-int get_scaled_rdigits(cbl_field_t *field);
-int get_scaled_digits(cbl_field_t *field);
-
-void get_binary_value( tree value,
- tree rdigits,
- cbl_field_t *field,
- tree field_offset,
- tree hilo = NULL);
-tree get_binary_value_tree(tree return_type,
- tree rdigits,
- cbl_field_t *field,
- tree field_offset,
- tree hilo = NULL);
-tree get_binary_value_tree(tree return_type,
- tree rdigits,
- const cbl_refer_t &refer,
- tree hilo = NULL);
+int get_scaled_rdigits(const cbl_field_t *field);
+int get_scaled_digits(const cbl_field_t *field);
+
tree get_data_address( cbl_field_t *field,
tree offset);
@@ -100,11 +86,6 @@ void set_exception_code_func(ec_type_t ec,
int from_raise_statement=0);
#define set_exception_code(ec) set_exception_code_func(ec, __LINE__)
bool process_this_exception(const ec_type_t ec);
-#define CHECK_FOR_FRACTIONAL_DIGITS true
-void get_integer_value(tree value, // This is always a LONG
- cbl_field_t *field,
- tree offset=NULL, // size_t
- bool check_for_fractional_digits=false);
void rt_error(const char *msg);
tree build_array_of_size_t( size_t N,
const size_t *values);
@@ -114,8 +95,10 @@ void parser_display_internal_field(tree
file_descriptor,
char *get_literal_string(cbl_field_t *field);
bool refer_is_clean(const cbl_refer_t &refer);
+bool field_is_super_clean(const cbl_field_t *field);
bool refer_is_super_clean(const cbl_refer_t &refer);
-bool refer_is_working_storage(const cbl_refer_t &refer);
+bool is_working_storage(const cbl_refer_t &refer);
+bool is_working_storage(const cbl_field_t *field);
tree refer_offset(const cbl_refer_t &refer, int *pflags=NULL);
tree refer_size_source(const cbl_refer_t &refer);
@@ -136,18 +119,34 @@ bool is_pure_integer(const cbl_field_t *field);
tree tree_type_from_field(const cbl_field_t *field);
tree tree_type_from_refer(const cbl_refer_t &refer);
-bool get_binary_value(tree &value,
+void get_binary_value(tree &value,
+ const cbl_field_t *field,
+ tree type = NULL_TREE);
+
+void get_binary_value(tree &value,
const cbl_refer_t &refer,
tree type = NULL_TREE);
+
+void get_location(tree &retval, const cbl_field_t *field);
void get_location(tree &retval, const cbl_refer_t &refer);
+
+void safe_cast(tree &target, // A defined variable.
+ tree source_location, // A pointer, usually UCHAR_P.
+ tree source_type); // The variable type pointed to
by
+ // source_location.
+void safe_cast(tree &target, // A defined variable.
+ const cbl_field_t *field);
+void safe_cast(tree &target, // A defined variable.
+ const cbl_refer_t &refer);
+
void get_length(tree &retval, const cbl_refer_t &refer);
void treeplet_fill_source(TREEPLET &treeplet, const cbl_refer_t &refer);
tree data_decl_type_for(cbl_field_t *field);
-void attribute_bit_clear(struct cbl_field_t *var, cbl_field_attr_t bits);
-tree attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits);
-void attribute_bit_set(struct cbl_field_t *var, cbl_field_attr_t bits);
+void attribute_bit_clear(const struct cbl_field_t *var, cbl_field_attr_t
bits);
+tree attribute_bit_get(const struct cbl_field_t *var, cbl_field_attr_t
bits);
+void attribute_bit_set(const struct cbl_field_t *var, cbl_field_attr_t
bits);
#endif
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index d57ae6b20ce..b718992fe2a 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -1790,7 +1790,7 @@ mh_binary_to_packed(const cbl_refer_t &destref,
}
static void
-copy_little_endian_into_place(cbl_field_t *dest,
+copy_native_into_place(cbl_field_t *dest,
tree dest_offset,
tree value,
int rhs_rdigits,
@@ -1842,7 +1842,20 @@ copy_little_endian_into_place(cbl_field_t *dest,
if( dest->type == FldNumericBinary )
{
- gg_assign(target, gg_bswap(target));
+ // We need the target to be big-endian.
+ if( BYTES_BIG_ENDIAN )
+ {
+ // 'target' is already big-endian, so we can leave it be.
+ }
+ else
+ {
+ // 'target' is little-endian, so make it big-endian
+ gg_assign(target, gg_bswap(target));
+ }
+ }
+ else
+ {
+ // We need the target to be native binary, so just leave it be
}
// Copy the target to the destination.
gg_memcpy(dest_pointer,
@@ -1851,14 +1864,14 @@ copy_little_endian_into_place(cbl_field_t *dest,
}
static bool
-mh_little_endian( const cbl_refer_t &destref,
+mh_to_binary( const cbl_refer_t &destref,
const cbl_refer_t &sourceref,
const TREEPLET &tsource,
bool check_for_error,
tree size_error)
{
- // The name of this routine is misleading. It also handles big-endian
- // destinations.
+ // This routine moves a numeric value to a binary destination. The
dest
+ // can be little-endian or big-endian.
bool moved = false;
@@ -1880,7 +1893,7 @@ mh_little_endian( const cbl_refer_t &destref,
SHOW_PARSE1
{
SHOW_PARSE_INDENT
- SHOW_PARSE_TEXT("mh_little_endian")
+ SHOW_PARSE_TEXT("mh_to_binary")
SHOW_PARSE_END
}
@@ -1907,7 +1920,7 @@ mh_little_endian( const cbl_refer_t &destref,
// Get binary value from float actually scales the source value to
the
// dest:: rdigits
- copy_little_endian_into_place(destref.field,
+ copy_native_into_place(destref.field,
refer_offset(destref),
source,
destref.field->data.rdigits,
@@ -1918,12 +1931,9 @@ mh_little_endian( const cbl_refer_t &destref,
else
{
tree source_type = tree_type_from_refer(sourceref);
- tree source = gg_define_variable(source_type);
- get_binary_value( source,
- NULL,
- sourceref.field,
- tsource.offset);
- copy_little_endian_into_place(destref.field,
+ tree source;
+ get_binary_value(source, sourceref, source_type);
+ copy_native_into_place(destref.field,
refer_offset(destref),
source,
sourceref.field->data.rdigits,
@@ -3450,7 +3460,7 @@ move_helper(tree size_error, // This is an
INT
if( !moved )
{
- moved = mh_little_endian( destref,
+ moved = mh_to_binary( destref,
sourceref,
tsource,
restore_on_error,
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 36e6331622b..5d22df96c2f 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -8035,27 +8035,31 @@ section_name: NAME section_kw '.'
;
section_kw: SECTION
- {
- if( $1 && dialect_ok(@1, IbmSectionSegmentW, "SECTION
segment") ) {
- cbl_message(@1, IbmSectionSegmentW,
- "SECTION segment %qs was ignored", $1);
- if( *$1 == '-' ) {
- cbl_message(@1, IbmSectionNegE,
- "SECTION segment %qs is negative", $1);
- } else {
- int sectno;
- sscanf($1, "%d", §no);
- if( ! (0 <= sectno && sectno <= 99) ) {
- cbl_message(@1, IbmSectionRangeE,
- "SECTION segment %qs must be 0-99",
$1);
- }
- }
- }
- }
- | SECTION error
- {
- error_msg(@1, "unknown section qualifier");
- }
+/* Dubner commented out this code on 2026-06-28 as part of getting the
+ compiler working on the IBM S390. It was failing in an off-by-one way;
+ the $1 parameter, on the S390, wasn't the section number, but rather
the
+ section name. */
+// {
+// if( $1 && dialect_ok(@1, IbmSectionSegmentW, "SECTION
segment") ) {
+// cbl_message(@1, IbmSectionSegmentW,
+// "SECTION segment %qs was ignored", $1);
+// if( *$1 == '-' ) {
+// cbl_message(@1, IbmSectionNegE,
+// "SECTION segment %qs is negative",
$1);
+// } else {
+// int sectno;
+// sscanf($1, "%d", §no);
+// if( ! (0 <= sectno && sectno <= 99) ) {
+// cbl_message(@1, IbmSectionRangeE,
+// "SECTION segment %qs must be
0-99", $1);
+// }
+// }
+// }
+// }
+// | SECTION error
+// {
+// error_msg(@1, "unknown section qualifier");
+// }
;
stop: STOP RUN exit_with
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index f329b8a6e21..62bd812c731 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -3208,10 +3208,10 @@ cbl_field_t::blank_initial( size_t nchar,
cbl_figconst_t figconst ) {
switch(codeset.stride()) {
case 1:
- blankit( reinterpret_cast<uint8_t*>(init), nchar, uint8_t(space_char)
);
+ blankit( reinterpret_cast<uint8_t*>(init), nchar,
uint8_t(space_char%0x100) );
break;
case 2:
- blankit( reinterpret_cast<uint16_t*>(init), nchar,
uint16_t(space_char) );
+ blankit( reinterpret_cast<uint16_t*>(init), nchar,
uint16_t(space_char%0x10000) );
break;
case 4:
blankit( reinterpret_cast<uint32_t*>(init), nchar,
uint32_t(space_char) );
diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h
index e1a84dcf5ce..69c7ee0abfb 100644
--- a/gcc/cobol/show_parse.h
+++ b/gcc/cobol/show_parse.h
@@ -317,7 +317,7 @@ extern bool cursor_at_sol;
gg_fprintf(trace_handle, 1, " (%s",
gg_string_literal(cbl_field_type_str((b)->type))); \
if( b->type != FldLiteralN && b->type != FldConditional ) \
{ \
- cbl_field_t* B(b); \
+ const cbl_field_t* B(b); \
if( !b->var_decl_node ) \
{ \
gg_fprintf(trace_handle, 0, #b "->var_decl_node is NULL",
NULL_TREE); \
diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc
index 004abaa1d49..54e42dd0e38 100644
--- a/gcc/cobol/structs.cc
+++ b/gcc/cobol/structs.cc
@@ -87,7 +87,7 @@ member(tree var, const char *member_name)
}
tree
-member(cbl_field_t *var, const char *member_name)
+member(const cbl_field_t *var, const char *member_name)
{
return gg_struct_field_ref(var->var_decl_node, member_name);
}
diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h
index aefea7f26d6..a9c7f879b46 100644
--- a/gcc/cobol/structs.h
+++ b/gcc/cobol/structs.h
@@ -34,8 +34,7 @@ extern tree var_decl_node_p_of( cbl_field_t *var );
// Simple fetch
extern tree member(tree var, const char *member_name);
-extern tree member(cbl_field_t *var, const char *member_name);
-extern tree member(cbl_refer_t refer, const char *member_name);
+extern tree member(const cbl_field_t *var, const char *member_name);
extern tree member(cbl_file_t *var, const char *member_name);
extern tree member2(tree var, const char *member_name, const char
*submember);
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 6f9c481a8d4..8cc7e146801 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -65,6 +65,9 @@
#include "../../libgcobol/charmaps.h"
#include "../../libgcobol/valconv.h"
+#include "tm.h"
+#include "target.h"
+
#pragma GCC diagnostic ignored "-Wunused-result"
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
@@ -1391,7 +1394,9 @@ binary_initial( char *retval,
int drdigits)
{
// This routine returns an xmalloced buffer designed to replace the
- // data.initial member of the incoming field
+ // data.initial member of the incoming field. The 'retval' becomes the
+ // binary representation of 'value' in the target machine's native
endian
+ // encoding.
int scaled_rdigits = get_scaled_rdigits(field);
@@ -1685,12 +1690,11 @@ cbl_field_t::encode_numeric( const char input[],
cbl_loc_t loc ) {
binary_initial(retval, this, value, l_rdigits);
if( attr & big_endian_e )
{
- // This is a big-endian value, so swap retval end-for-end:
- size_t left = 0;
- size_t right = data.capacity() - 1;
- while(left < right)
+ if(!BYTES_BIG_ENDIAN)
{
- std::swap(retval[left++], retval[right--]);
+ // The target is little-endian, so we have to swap our value
to make
+ // it big-endian.
+ std::reverse(retval, retval + data.capacity());
}
}
break;
@@ -1848,7 +1852,27 @@ cbl_field_t::encode_numeric( const char input[],
cbl_loc_t loc ) {
: retval + (data.digits-1) * charmap->stride() ;
cbl_char_t schar = charmap->set_digit_negative(*sign_location,
negative);
- memcpy(sign_location, &schar, charmap->stride());
+ switch(charmap->stride())
+ {
+ case 1:
+ {
+ uint8_t v = schar;
+ memcpy(sign_location, &v, charmap->stride());
+ break;
+ }
+ case 2:
+ {
+ uint16_t v = schar;
+ memcpy(sign_location, &v, charmap->stride());
+ break;
+ }
+ case 4:
+ {
+ uint32_t v = schar;
+ memcpy(sign_location, &v, charmap->stride());
+ break;
+ }
+ }
}
break;
}
diff --git
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.cob
b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.cob
deleted file mode 100644
index 92c58287215..00000000000
---
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.cob
+++ /dev/null
@@ -1,123 +0,0 @@
- *> { dg-do run }
- *> { dg-output-file
"group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out" }
- identification division.
- program-id. prog.
- procedure division.
- display "initialize zeroes"
- call "prog-zeroes"
- display "initialize low-value"
- call "prog-low"
- display "initialize spaces"
- call "prog-space"
- display "initialize high-value"
- call "prog-high"
- continue.
- end program prog.
-
- identification division.
- program-id. prog-space.
- options. initialize working-storage spaces.
- data division.
- working-storage section.
- 01 based-var based.
- 02 based-x pic x(24) value "I am I, Don Quixote".
- 02 based-9 pic 999 value 123.
- 02 based-p pointer value NULL.
- 01 allocated-pointer pointer.
- procedure division.
- display "allocate characters (ISO 2023 Rule 8: OPT_INIT if
specified, otherwise defaultbyte, otherwise zero)"
- allocate 35 characters returning allocated-pointer
- set address of based-var to allocated-pointer
- call "reporter" using based-var
- free allocated-pointer
- goback.
- end program prog-space.
-
- identification division.
- program-id. prog-low.
- options. initialize working-storage low-values.
- data division.
- working-storage section.
- 01 based-var based.
- 02 based-x pic x(24) value "I am I, Don Quixote".
- 02 based-9 pic 999 value 123.
- 02 based-p pointer value NULL.
- 01 allocated-pointer pointer.
- procedure division.
- display "allocate characters (ISO 2023 Rule 8: OPT_INIT if
specified, otherwise defaultbyte, otherwise zero)"
- allocate 35 characters returning allocated-pointer
- set address of based-var to allocated-pointer
- call "reporter" using based-var
- free allocated-pointer
- goback.
- end program prog-low.
-
- identification division.
- program-id. prog-zeroes.
- options. initialize working-storage binary zeroes.
- data division.
- working-storage section.
- 01 based-var based.
- 02 based-x pic x(24) value "I am I, Don Quixote".
- 02 based-9 pic 999 value 123.
- 02 based-p pointer value NULL.
- 01 allocated-pointer pointer.
- procedure division.
- display "allocate characters (ISO 2023 Rule 8: OPT_INIT if
specified, otherwise defaultbyte, otherwise zero)"
- allocate 35 characters returning allocated-pointer
- set address of based-var to allocated-pointer
- call "reporter" using based-var
- free allocated-pointer
- goback.
- end program prog-zeroes.
-
- identification division.
- program-id. prog-high.
- options. initialize working-storage high-values.
- data division.
- working-storage section.
- 01 based-var based.
- 02 based-x pic x(24) value "I am I, Don Quixote".
- 02 based-9 pic 999 value 123.
- 02 based-p pointer value NULL.
- 01 pval redefines based-var pointer.
- 01 allocated-pointer pointer.
- procedure division.
- display "allocate characters (ISO 2023 Rule 8: OPT_INIT if
specified, otherwise defaultbyte, otherwise zero)"
- allocate 35 characters returning allocated-pointer
- set address of based-var to allocated-pointer
- display pval
- free allocated-pointer
- goback.
- end program prog-high.
-
- identification division.
- program-id. reporter.
- data division.
- working-storage section.
- 01.
- 02 asciiv pic x(8) value X"2020202020202020".
- 02 asciip redefines asciiv pointer.
- 02 ebcdicv pic x(8) value X"4040404040404040".
- 02 ebcdicp redefines ebcdicv pointer.
- linkage section.
- 01 based-var based.
- 02 based-x pic x(24).
- 02 based-9 pic 999 .
- 02 based-p pointer .
- procedure division using based-var.
- reportt.
- display " (1) as allocated"
- perform reportt2
- goback.
- reportt2.
- display " " """" based-x """" with no advancing
- display space """" based-9 """" with no advancing
- if based-p = asciip or ebcdicp
- display " Pointer is Okay"
- else
- display space based-p
- end-if
- continue.
- end program reporter.
-
diff --git
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.out
b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.out
deleted file mode 100644
index 0a288a3ceaf..00000000000
---
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_fig
const.out
+++ /dev/null
@@ -1,16 +0,0 @@
-initialize zeroes
-allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
- (1) as allocated
- "" "000" 0x0000000000000000
-initialize low-value
-allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
- (1) as allocated
- "" "000" 0x0000000000000000
-initialize spaces
-allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
- (1) as allocated
- " " "000" Pointer is Okay
-initialize high-value
-allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
-0xffffffffffffffff
-
diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h
index a16caa57ea8..1e53df78275 100644
--- a/libgcobol/charmaps.h
+++ b/libgcobol/charmaps.h
@@ -128,7 +128,7 @@ extern uint32_t __gg__wsclear;
enum
{
/* HIGH-VALUE is an endless source of irritation.
-
+
0xFF is the default value for COBOL since time immemorial. Its use
that
way long predates the existence of code pages. 0xFF is a valid
character
in many code pages, which make a muddle of the original intent of a
@@ -137,7 +137,7 @@ enum
We want older programs to continue to work. And we want to use 0xFF
for
ascii and ebcdic, and it turns out that 0xFFFF works for UTF-16; it
is
specifically designed in UNICODE as a well-formed non-character.
-
+
0xFFFFFFFF, however, is not readily usable in UTF-32. It is not
well-
formed, and it is not a character. Technically, the largest value
in
UTF-32 is the largest UNICODE code point, which is 0x10FFFF. It's
@@ -145,9 +145,9 @@ enum
map into a single 16-bit value in UTF-16 (it takes a pair of 16-bit
values), and it doesn't map into anything sensible in ASCII or
EBCDIC, and
it takes multiple bytes in UTF-8.
-
+
So, we are going to work with the following observations:
-
+
0xFF in CP1252 <==> 0x000000FF in UTF32
0xFF in CP1140 <==> 0x0000009F in UTF32
0xFFFF in UTF-16 <==> 0x0000FFFF in UTF32
@@ -155,14 +155,14 @@ enum
Be it hereby acknowledged that not all possibilities for encoding
inter-
conversion have been explored, and we anticipate finding and
eliminating
HIGH-VALUE problems will be Whac-A-Mole territory for some time to
come.
-
+
Please use these constants for that kind of work, because otherwise
finding anomalies will be even more frustrating than I currently
anticipate. Dubner, 2025-11-24 */
DEFAULT_HIGH_VALUE_8 = 0xFF,
DEFAULT_HIGH_VALUE_16 = 0x00FF,
DEFAULT_HIGH_VALUE_32 = 0x000000FF,
-
+
/* These values are used as figurative constants when interconverting
from
and encoding to UTF32. Examine, for example, the implementation for
the INSPECT statement: */
@@ -324,7 +324,7 @@ class charmap_t;
* If used in the compiler, failure results in a compiler error message.
If
* used in libgcobol, failure raises EC-IMP-ICONV-OPEN.
*
- * The destructor closes all handles successfully opened.
+ * The destructor closes all handles successfully opened.
*/
class cbl_iconv_t {
struct iconv_key_t {
@@ -338,7 +338,7 @@ class cbl_iconv_t {
: to(to), from(from)
, tocode(__gg__encoding_iconv_name(to))
, fromcode(__gg__encoding_iconv_name(from))
-
+
{}
iconv_key_t( const char *tocode, const char *fromcode )
: to(__gg__encoding_iconv_type(tocode))
@@ -432,7 +432,7 @@ class charmap_t
// We do that by converting "0" to the target encoding, and we
analyze
// what we get back.
-
+
size_t outlength = 0;
char challenge[] = "0";
char response_[8];
@@ -440,7 +440,7 @@ class charmap_t
iconv_t cd = cbl_iconv.open(m_encoding, DEFAULT_SOURCE_ENCODING);
if( ! cbl_iconv.valid(cd) ) {
- return; // Abandon all hope ye who enter.
+ return; // All hope abandon, ye who enter here.
}
char *inbuf = challenge;
char *outbuf = response_;
@@ -450,10 +450,10 @@ class charmap_t
&inbuf, &inbytesleft,
&outbuf, &outbytesleft);
outlength = sizeof(response_) - outbytesleft;
-
- const unsigned char *response =
+
+ const unsigned char *response =
reinterpret_cast<unsigned char
*>(response_);
-
+
unsigned char char_0 = 0x00;
if( outlength == 1 )
@@ -534,7 +534,7 @@ class charmap_t
// the single-byte CP1252 code for the Euro symbol to our encoding.
cd = cbl_iconv.open(iconv_CP1252_e, m_encoding);
if( ! cbl_iconv.valid(cd) ) {
- return; // Abandon all hope ye who enter.
+ return; // All hope abandon, ye who enter here.
}
challenge[0] = static_cast<char>(0x80);// This is the CP1252 Euro
symbol.
inbuf = challenge;
@@ -553,7 +553,7 @@ class charmap_t
bool has_bom() const { return m_has_bom ; }
uint8_t stride() const { return m_stride ; }
- cbl_char_t mapped_character(cbl_char_t ch)
+ cbl_char_t mapped_character(unsigned char ch)
{
// The assumption is that anybody calling this routine is providing
// a single-byte character in the DEFAULT_SOURCE_ENCODING encoding.
We
@@ -569,12 +569,23 @@ class charmap_t
{
retval = 0;
size_t outlength = 0;
- const char *mapped = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
- m_encoding,
- PTRCAST(char, &ch),
- 1,
- &outlength);
- memcpy(&retval, mapped, outlength);
+ char *mapped = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
+ m_encoding,
+ &ch,
+ 1,
+ &outlength);
+ switch(stride())
+ {
+ case 1:
+ retval = *reinterpret_cast<uint8_t *>(mapped);
+ break;
+ case 2:
+ retval = *reinterpret_cast<uint16_t *>(mapped);
+ break;
+ case 4:
+ retval = *reinterpret_cast<uint32_t *>(mapped);
+ break;
+ }
m_map_of_encodings[ch] = retval;
}
return retval;
@@ -621,9 +632,9 @@ class charmap_t
return retval;
}
- cbl_char_t figconst_character(cbl_figconst_t figconst)
+ uint8_t figconst_character(cbl_figconst_t figconst)
{
- cbl_char_t const_char = 0; // Head off a compiler warning
+ uint8_t const_char = 0; // Head off a compiler warning
switch(figconst)
{
case normal_value_e :
@@ -829,75 +840,54 @@ class charmap_t
void putch(cbl_char_t ch, void *base_, size_t location)
{
- // This routine puts a character at a byte location. It's up to the
- // user to provide the correct byte location, and update it by the
stride
- // when necessary.
+ // This routine puts a character at a byte location.
uint8_t *base = static_cast<uint8_t *>(base_);
- memcpy(base+location, &ch, m_stride);
- if( m_stride < 4 )
+ switch(m_stride)
{
- location += m_stride;
- ch >>= (8 * m_stride);
- while(ch)
- {
- memcpy(base+location, &ch, m_stride);
- location += m_stride;
- ch >>= (8 * m_stride);
- }
+ case 1:
+ *reinterpret_cast<uint8_t*>(base+location) = ch;
+ break;
+ case 2:
+ *reinterpret_cast<uint16_t*>(base+location) = ch;
+ break;
+ default:
+ *reinterpret_cast<uint32_t*>(base+location) = ch;
+ break;
}
}
void putch(cbl_char_t ch, void *base_, size_t *location)
{
// This routine puts a character at a location, and updates the
location
- uint8_t *base = static_cast<uint8_t *>(base_);
- memcpy(base+*location, &ch, m_stride);
+ this->putch(ch, base_, *location);
*location += m_stride;
- if( m_stride < 4 )
- {
- ch >>= 8 * m_stride;
- while(ch)
- {
- memcpy(base+*location, &ch, m_stride);
- *location += m_stride;
- ch >>= 8 * m_stride;
- }
- }
}
cbl_char_t getch(const void *base_, size_t location) const
{
- // This routine gets a character at a location, and updates the
location
- cbl_char_t retval = 0;
+ // This routine gets a character at a location
+ cbl_char_t retval;
const uint8_t *base = static_cast<const uint8_t *>(base_);
-
- memcpy(&retval, base+location, m_stride);
-//// location += m_stride;
-//// We need to do something about UTF-8 snd UTF-16
-//// while(ch)
-//// {
-//// memcpy(base+*location, &ch, m_stride);
-//// *location += m_stride;
-//// ch >>= 8 * m_stride;
-//// }
+ switch(m_stride)
+ {
+ case 1:
+ retval = *reinterpret_cast<const uint8_t*>(base+location);
+ break;
+ case 2:
+ retval = *reinterpret_cast<const uint16_t*>(base+location);
+ break;
+ default:
+ retval = *reinterpret_cast<const uint32_t*>(base+location);
+ break;
+ }
return retval;
}
cbl_char_t getch(const void *base_, size_t *location) const
{
// This routine gets a character at a location, and updates the
location
- cbl_char_t retval = 0;
- const uint8_t *base = static_cast<const uint8_t *>(base_);
-
- memcpy(&retval, base+*location, m_stride);
+ cbl_char_t retval = this->getch(base_, *location);
*location += m_stride;
-//// We need to do something about UTF-8 snd UTF-16
-//// while(ch)
-//// {
-//// memcpy(base+*location, &ch, m_stride);
-//// *location += m_stride;
-//// ch >>= 8 * m_stride;
-//// }
return retval;
}
@@ -942,7 +932,7 @@ class charmap_t
//// gcc_unreachable();
return -1; // Mollify cppcheck.
}
-
+
size_t
strlen( const void *converted,
ssize_t limit = SSIZE_MAX)
diff --git a/libgcobol/inspect.cc b/libgcobol/inspect.cc
index 8f6cc2b3b7d..14010242918 100644
--- a/libgcobol/inspect.cc
+++ b/libgcobol/inspect.cc
@@ -319,7 +319,7 @@ normalize_id( const cblc_field_t *field,
}
else
{
- char ch = charmap->figconst_character(figconst);
+ uint8_t ch = charmap->figconst_character(figconst);
for( size_t i=retval.offset; i<retval.length; i+=1 )
{
retval.the_characters += ch;
@@ -424,7 +424,7 @@ normalize_id( const cblc_field_t *field,
// We need to fill the field with a figurative constant:
// We are set up to create the_characters;
charmap_t *charmap32 = __gg__get_charmap(DEFAULT_32_ENCODING);
- char ch = charmap32->figconst_character(figconst);
+ uint8_t ch = charmap32->figconst_character(figconst);
for( size_t i=retval.offset; i<retval.length; i+=1 )
{
retval.the_characters += ch;
@@ -500,7 +500,7 @@ normalize_id_sbc( const cblc_field_t *field,
else
{
// This field is flagged as figconst
- char ch = charmap->figconst_character(figconst);
+ uint8_t ch = charmap->figconst_character(figconst);
retval.assign(field_s, ch);
}
}
diff --git a/libgcobol/libgcobol-fp.h b/libgcobol/libgcobol-fp.h
index fcfa0a79b6b..8fabd87241d 100644
--- a/libgcobol/libgcobol-fp.h
+++ b/libgcobol/libgcobol-fp.h
@@ -49,6 +49,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.
If not, see
# define strtofp128(nptr, endptr) strtoflt128(nptr, endptr)
# define strfromfp128(str, n, format, fp) quadmath_snprintf(str, n,
format, fp)
#else
+// cppcheck-suppress preprocessorErrorDirective
# error "libgcobol requires 128b floating point"
#endif
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 7619a2b8904..1e2c7a0e4c5 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -698,95 +698,163 @@ edited_to_binary( const cblc_field_t *field,
static
__int128
-big_endian_to_binary_signed(
- const unsigned char *psource,
- int capacity
-)
+native_to_binary_signed(void *psource,
+ int capacity )
{
- // This subroutine takes a big-endian value of "capacity" bytes and
- // converts it to a signed INT128. The highest order bit of the
big-endian
- // value determines whether or not the highest-order bits of the INT128
- // return value are off or on.
-
- __int128 retval;
- if( *psource >= 128 )
- {
- retval = -1;
- }
- else
- {
- retval = 0;
- }
-
- // move the bytes of psource into retval, flipping them end-to-end
- unsigned char *dest = PTRCAST(unsigned char, &retval);
- while(capacity > 0)
+ __int128 result;
+ switch(capacity)
{
- *dest++ = psource[--capacity];
+ case 1:
+ result = *reinterpret_cast<int8_t *>(psource);
+ break;
+ case 2:
+ result = *reinterpret_cast<int16_t *>(psource);
+ break;
+ case 4:
+ result = *reinterpret_cast<int32_t *>(psource);
+ break;
+ case 8:
+ result = *reinterpret_cast<int64_t *>(psource);
+ break;
+ case 16:
+ result = *reinterpret_cast<__int128 *>(psource);
+ break;
}
- return retval;
+ return result;
}
static
__int128
-little_endian_to_binary_signed(
- const unsigned char *psource,
- int capacity
-)
+native_to_binary_unsigned(void *psource,
+ int capacity)
{
- // This subroutine takes a little-endian value of "capacity" bytes and
- // converts it to a signed INT128. The highest order bit of the
little-endian
- // value determines whether or not the highest-order bits of the INT128
- // return value are off or on.
-
__int128 result;
-
- // Set all the bits of the result based on the sign of the source:
- if( psource[capacity-1] >= 128 )
- {
- result = -1;
- }
- else
+ switch(capacity)
{
- result = 0;
+ case 1:
+ result = *reinterpret_cast<uint8_t *>(psource);
+ break;
+ case 2:
+ result = *reinterpret_cast<uint16_t *>(psource);
+ break;
+ case 4:
+ result = *reinterpret_cast<uint32_t *>(psource);
+ break;
+ case 8:
+ result = *reinterpret_cast<uint64_t *>(psource);
+ break;
+ case 16:
+ result = *reinterpret_cast<unsigned __int128 *>(psource);
+ break;
}
-
- // Copy the low-order bytes into place:
- memcpy(&result, psource, capacity);
return result;
}
static
__int128
-little_endian_to_binary_unsigned(
- const unsigned char *psource,
- int capacity
-)
+big_endian_to_binary_unsigned(const void *psource,
+ int capacity)
{
- __int128 result = 0;
+ // This subroutine takes an unsigned big-endian value of "capacity"
bytes and
+ // converts it to an INT128.
- // Copy the low-order bytes into place:
- memcpy(&result, psource, capacity);
- return result;
+ unsigned __int128 retval = 0 ;
+
+ switch(capacity)
+ {
+ case 1:
+ {
+ uint8_t v;
+ memcpy(&v, psource, sizeof(v));
+ retval = v;
+ break;
+ }
+ case 2:
+ {
+ uint16_t v;
+ memcpy(&v, psource, sizeof(v));
+ #if COBOL_LITTLE_ENDIAN
+ // This is a little-endian machine, so we have to flip the value.
+ v = __builtin_bswap16(v);
+ #endif
+ retval = v;
+ break;
+ }
+ case 4:
+ {
+ uint32_t v;
+ memcpy(&v, psource, sizeof(v));
+ #if COBOL_LITTLE_ENDIAN
+ v = __builtin_bswap32(v);
+ #endif
+ retval = v;
+ break;
+ }
+ case 8:
+ {
+ uint64_t v;
+ memcpy(&v, psource, sizeof(v));
+ #if COBOL_LITTLE_ENDIAN
+ v = __builtin_bswap64(v);
+ #endif
+ retval = v;
+ break;
+ }
+ case 16:
+ {
+ unsigned __int128 v;
+ memcpy(&v, psource, sizeof(v));
+ #if COBOL_LITTLE_ENDIAN
+ v = __builtin_bswap128(v);
+ #endif
+ retval = v;
+ break;
+ }
+ }
+ return retval;
}
-static
-__int128
-big_endian_to_binary_unsigned(
- const unsigned char *psource,
- int capacity
-)
+static __int128
+big_endian_to_binary_signed(const void *psource, int capacity)
{
- // This subroutine takes an unsigned big-endian value of "capacity"
bytes and
- // converts it to an INT128.
-
- __int128 retval = 0 ;
+ __int128 retval;
+ unsigned __int128 u = big_endian_to_binary_unsigned(psource, capacity);
- // move the bytes of psource into retval, flipping them end-to-end
- unsigned char *dest = PTRCAST(unsigned char, &retval);
- while(capacity > 0)
+ switch (capacity)
{
- *dest++ = psource[--capacity];
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ {
+ int bits = capacity * 8;
+
+ unsigned __int128 sign_bit =
+ (static_cast<unsigned __int128>(1)) << (bits - 1);
+
+ if(u & sign_bit)
+ {
+ unsigned __int128 extension =
+ (~static_cast<unsigned __int128>(0)) << bits;
+
+ u |= extension;
+ }
+
+ retval = u;
+ break;
+ }
+
+ case 16:
+ {
+ /* Already a full-width 128-bit quantity. Returning it as signed
+ interprets the high bit as the sign bit on GCC/two's-complement
+ targets. */
+ retval = u;
+ break;
+ }
+
+ default:
+ abort();
}
return retval;
}
@@ -911,13 +979,13 @@ get_binary_value_local( int
*rdigits,
if( resolved_var->attr & signable_e)
{
retval = big_endian_to_binary_signed(
- PTRCAST(const unsigned char, resolved_location),
+ resolved_location,
resolved_length);
}
else
{
retval = big_endian_to_binary_unsigned(
- PTRCAST(const unsigned char, resolved_location),
+ resolved_location,
resolved_length);
}
*rdigits = resolved_var->rdigits;
@@ -927,12 +995,12 @@ get_binary_value_local( int
*rdigits,
{
if( resolved_var->attr & signable_e)
{
- retval = little_endian_to_binary_signed(resolved_var->data,
+ retval = native_to_binary_signed(resolved_var->data,
resolved_var->capacity);
}
else
{
- retval = little_endian_to_binary_unsigned(resolved_var->data,
+ retval = native_to_binary_unsigned(resolved_var->data,
resolved_var->capacity);
}
*rdigits = resolved_var->rdigits;
@@ -944,14 +1012,14 @@ get_binary_value_local( int
*rdigits,
case FldPointer:
if( resolved_var->attr & signable_e)
{
- retval = little_endian_to_binary_signed(
- PTRCAST(const unsigned char, resolved_location),
+ retval = native_to_binary_signed(
+ resolved_location,
resolved_length);
}
else
{
- retval = little_endian_to_binary_unsigned(
- PTRCAST(const unsigned char, resolved_location),
+ retval = native_to_binary_unsigned(
+ resolved_location,
resolved_length);
}
*rdigits = resolved_var->rdigits;
@@ -1247,41 +1315,147 @@ value_is_too_big(const cblc_field_t *var,
static void
binary_to_big_endian( unsigned char *dest,
int bytes,
- __int128 value
- )
- {
- if( value < 0 )
- {
- memset(dest, 0xFF, bytes);
+ __int128 value,
+ bool signable )
+ {
+ // value is native, and we want the result to be big-endian.
+ if( signable )
+ {
+ int8_t v8;
+ int16_t v16;
+ int32_t v32;
+ int64_t v64;
+ __int128 v128;
+ switch(bytes)
+ {
+ case 1:
+ v8 = value;
+ *reinterpret_cast<int8_t*>(dest) = v8;
+ break;
+ case 2:
+ v16 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v16 = __builtin_bswap16(v16);
+ #endif
+ *reinterpret_cast<int16_t*>(dest) = v16;
+ break;
+ case 4:
+ v32 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v32 = __builtin_bswap32(v32);
+ #endif
+ *reinterpret_cast<int32_t*>(dest) = v32;
+ break;
+ case 8:
+ v64 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v64 = __builtin_bswap64(v64);
+ #endif
+ *reinterpret_cast<int64_t*>(dest) = v64;
+ break;
+ default:
+ v128 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v128 = __builtin_bswap128(v128);
+ #endif
+ *reinterpret_cast<__int128*>(dest) = v128;
+ break;
+ }
}
else
{
- memset(dest, 0x00, bytes);
- }
-
- dest += bytes-1;
- while( bytes-- )
- {
- *dest-- = (unsigned char) value;
- value >>= 8;
+ uint8_t v8;
+ uint16_t v16;
+ uint32_t v32;
+ uint64_t v64;
+ unsigned __int128 v128;
+ switch(bytes)
+ {
+ case 1:
+ v8 = value;
+ *reinterpret_cast<uint8_t*>(dest) = v8;
+ break;
+ case 2:
+ v16 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v16 = __builtin_bswap16(v16);
+ #endif
+ *reinterpret_cast<uint16_t*>(dest) = v16;
+ break;
+ case 4:
+ v32 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v32 = __builtin_bswap32(v32);
+ #endif
+ *reinterpret_cast<uint32_t*>(dest) = v32;
+ break;
+ case 8:
+ v64 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v64 = __builtin_bswap64(v64);
+ #endif
+ *reinterpret_cast<uint64_t*>(dest) = v64;
+ break;
+ default:
+ v128 = value;
+ #if COBOL_LITTLE_ENDIAN
+ v128 = __builtin_bswap128(v128);
+ #endif
+ *reinterpret_cast<unsigned __int128*>(dest) = v128;
+ break;
+ }
}
}
static void
-binary_to_little_endian( unsigned char *dest,
- int bytes,
- __int128 value
+binary_to_native_binary( void *dest,
+ int bytes,
+ __int128 value,
+ bool signable
)
{
- if( value < 0 )
+ if(signable)
{
- memset(dest, 0xFF, bytes);
+ switch(bytes)
+ {
+ case 1:
+ *reinterpret_cast<int8_t * >(dest) = value;
+ break;
+ case 2:
+ *reinterpret_cast<int16_t * >(dest) = value;
+ break;
+ case 4:
+ *reinterpret_cast<int32_t * >(dest) = value;
+ break;
+ case 8:
+ *reinterpret_cast<int64_t * >(dest) = value;
+ break;
+ case 16:
+ *reinterpret_cast<__int128 * >(dest) = value;
+ break;
+ }
}
else
{
- memset(dest, 0x00, bytes);
+ switch(bytes)
+ {
+ case 1:
+ *reinterpret_cast<uint8_t * >(dest) = value;
+ break;
+ case 2:
+ *reinterpret_cast<uint16_t * >(dest) = value;
+ break;
+ case 4:
+ *reinterpret_cast<uint32_t * >(dest) = value;
+ break;
+ case 8:
+ *reinterpret_cast<uint64_t * >(dest) = value;
+ break;
+ case 16:
+ *reinterpret_cast<unsigned __int128 * >(dest) = value;
+ break;
+ }
}
- memcpy(dest, &value, bytes);
}
static __int128
@@ -1972,7 +2146,8 @@ int128_to_field(cblc_field_t *var,
case FldNumericBinary:
binary_to_big_endian( location,
length,
- value);
+ value,
+ !!(var->attr&signable_e));
size_error = value_is_too_big(var, value, source_rdigits);
break;
@@ -1985,9 +2160,10 @@ int128_to_field(cblc_field_t *var,
// will become one, but it is, apparently harmless. The
HIGH-VALUE
// must get processed separately elsewhere. As the author,
it
// would be nice if I knew -- but I don't.
- binary_to_little_endian(location,
+ binary_to_native_binary( location,
length,
- value);
+ value,
+ !!(var->attr&signable_e));
size_error = value_is_too_big(var, value, source_rdigits);
break;
diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h
index 9fcd523c071..37b1783e4fc 100644
--- a/libgcobol/libgcobol.h
+++ b/libgcobol/libgcobol.h
@@ -39,10 +39,31 @@
Some are also called between source code modules in libgcobol, hence
the
need here for declarations. */
-extern void __gg__mabort();
+// The runtime might be on a little-endian machine, and it might be on a
+// big-endian machine, most notably the IBM S390 series.
+
+#if defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
+# define COBOL_BIG_ENDIAN 1
+# define COBOL_LITTLE_ENDIAN 0
+#elif defined(__BYTE_ORDER__) && __BYTE_ORDER__ ==
__ORDER_LITTLE_ENDIAN__
+# define COBOL_BIG_ENDIAN 0
+# define COBOL_LITTLE_ENDIAN 1
+
+#elif defined(__BIG_ENDIAN__) || defined(_BIG_ENDIAN)
+# define COBOL_BIG_ENDIAN 1
+# define COBOL_LITTLE_ENDIAN 0
+#elif defined(__LITTLE_ENDIAN__) || defined(_LITTLE_ENDIAN)
+# define COBOL_BIG_ENDIAN 0
+# define COBOL_LITTLE_ENDIAN 1
+
+//#else
+cppcheck-suppress preprocessorErrorDirective
+# error "Unknown byte order"
+#endif
+extern void __gg__mabort();
-// The unnecessary abort() that follows is necessary to make cppcheck be
+// The unnecessary abort() that follows is necessary to make cppcheck be
// aware that massert() actually terminates processing after a failed
// malloc().
#define massert(p) if(!p){__gg__mabort();abort();}
diff --git a/libgcobol/stringbin.cc b/libgcobol/stringbin.cc
index acf2fff02a0..2ca36e66246 100644
--- a/libgcobol/stringbin.cc
+++ b/libgcobol/stringbin.cc
@@ -132,7 +132,6 @@ typedef struct
union
{
unsigned __int128 val128;
- uint64_t val64;
};
} COMBINED;
@@ -393,6 +392,7 @@ packed_from_combined(const COMBINED &combined)
{
// Stage 1: pull from int128 until the top half is zero.
__int128 value128 = combined.val128;
+#if COBOL_LITTLE_ENDIAN
while(value128>>64)
{
*(--d) = bin2pd[value128%100];
@@ -405,10 +405,22 @@ packed_from_combined(const COMBINED &combined)
*(--d) = bin2pd[value64%100];
value64 /= 100;
}
+#else
+ // The cute trick for little-endian is trickier in big-endian. Right
now
+ // it's late, and I don't feel like it. It would be easier if there
were
+ // __int128 constants, because the test up above could be
+ // while(value128/2^64)
+ // but that's not available as of this writing.
+ while(d > combined_string)
+ {
+ *(--d) = bin2pd[value128%100];
+ value128 /= 100;
+ }
+#endif
}
else
{
- uint64_t value = combined.val64;
+ uint64_t value = combined.val128;
while(d > combined_string)
{
*(--d) = bin2pd[value%100];
--
2.34.1
