};
struct cbl_loc_t : public cbl_loc_base_t {
- cbl_loc_t() = default;
+ cbl_loc_t() = default; // cppcheck-suppress uninitDerivedMemberVar
cbl_loc_t( int first_line, int first_column,
int last_line, int last_column )
an executable binary or shared object. As a GCC component, it accepts
all options that affect code-generation and linking. Options specific
to \*[lang] are listed below.
-.Bl -tag -width "\0\0debug"
+.Bl -tag -width 00debug
.It Fl main Ar filename
.Nm
will generate a
Warn if IBM-style STOP <number> is used (instead of error).
.It Fl Wno-stray-indicator
Warn if indicator column has no recognized meaning (instead of error).
-
.El
.
.Sh COMPILATION SCENARIOS
.
.Ss CDF Text Manipulation
.Bl -tag -width >>DEFINE
-.It Sy COPY Ar copybook Li Oo OF|IN Ar library Oc Oo Sy REPLACING ... Oc
+.It Sy COPY Ar copybook Oo Li OF|IN Ar library Oc Oo Sy REPLACING ... Oc
If
.Ar copybook
is a literal, it treated a literal filename, which either does or does not exist. If
.El
.
.Ss Status of NIST \*[lang] Compiler Verification Suite
-.Bl -tag -compact -width "\0\0100% NC"
+.Bl -tag -compact -width "00100% NC"
.It NC 100%
Nucleus
.It SQ 100%
.El
.
.Sh COPYRIGHT
-.Bd -unfilled -indent
+.Bd -unfilled
Copyright (c) 2021-2026 Symas Corporation
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
-* Redistributions of source code must retain the above copyright
-notice, this list of conditions and the following disclaimer.
-* Redistributions in binary form must reproduce the above
-copyright notice, this list of conditions and the following disclaimer
-in the documentation and/or other materials provided with the
-distribution.
-* Neither the name of the Symas Corporation nor the names of its
-contributors may be used to endorse or promote products derived from
-this software without specific prior written permission.
+\(bu Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+\(bu Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following disclaimer
+ in the documentation and/or other materials provided with the
+ distribution.
+\(bu Neither the name of the Symas Corporation nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
}
void
-parser_accept_date_yymmdd( struct cbl_field_t *target )
+parser_accept_date_yymmdd( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_END
}
+ auto target = refer.field;
CHECK_FIELD(target);
gg_call(VOID,
"__gg__get_date_yymmdd",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
void
-parser_accept_date_yyyymmdd( struct cbl_field_t *target )
+parser_accept_date_yyyymmdd( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_HEADER
SHOW_PARSE_END
}
+ auto target = refer.field;
gg_call(VOID,
"__gg__get_date_yyyymmdd",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
void
-parser_accept_date_yyddd( struct cbl_field_t *target )
+parser_accept_date_yyddd( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_END
}
+ auto target = refer.field;
CHECK_FIELD(target);
gg_call(VOID,
"__gg__get_date_yyddd",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
void
-parser_accept_date_yyyyddd( struct cbl_field_t *target )
+parser_accept_date_yyyyddd( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_END
}
+ auto target = refer.field;
CHECK_FIELD(target);
gg_call(VOID,
"__gg__get_yyyyddd",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
void
-parser_accept_date_dow( struct cbl_field_t *target )
+parser_accept_date_dow( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_END
}
+ auto target = refer.field;
CHECK_FIELD(target);
gg_call(VOID,
"__gg__get_date_dow",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
void
-parser_accept_date_hhmmssff( struct cbl_field_t *target )
+parser_accept_date_hhmmssff( const cbl_refer_t& refer )
{
Analyze();
SHOW_PARSE
SHOW_PARSE_END
}
+ auto target = refer.field;
CHECK_FIELD(target);
gg_call(VOID,
"__gg__get_date_hhmmssff",
gg_get_address_of(target->var_decl_node),
+ refer_offset(refer),
+ refer_size_dest(refer),
NULL_TREE);
TRACE1
{
}
}
first_time = false;
+
+ // We need to propagate the based_e attribute:
+ cbl_field_of(&element)->attr |= based_e;
+
if( this_one->level == 00 )
{
// Ignore LEVEL00 "INDEXED BY" variables
}
-//#pragma message "parser_file_open: consult cbl_file_t::filename_of and cbl_file_t::device"
-
/*
- * The filename of a cbl_file_t may be found in three places:
+ * The filename of a cbl_file_t may be found in three places:
* 1. As before, in the cbl_field_t indexed by cbl_file_t::filename.
* 2. Now, in the cbl_special_name_t indexed by cbl_file_t::device.
- * 3. As ever, in neither, from the environment.
+ * 3. As ever, in neither, from the environment.
*
* If both filename and device are nonzero and not FldForward, the filename
- * supersedes. The syntax was
- * SELECT fd-name ASSIGN TO device-name USING filename
+ * supersedes. The syntax was
+ * SELECT fd-name ASSIGN TO device-name USING filename
* That just creates in the parser an alias of device-name to fd-name. It's
* still the same file and does *not* change the device characteristics.
*
* taken from cbl_special_name_t::os_filename. It is tiny, hard-coded name
* in /dev.
*
- * Upon implementation please feel free to delete this message.
* --jkl
*/
-
tree pszFilename = gg_define_char_star();
cbl_field_t *field_of_name = symbol_field_forward(file->filename);
if( field_of_name->type == FldForward )
}
ELSE
{
- // We have a bad function pointer, which is the except condition:
+ // We have a bad function pointer, which is the exception condition:
+ // Set the exception message to "name"
+ gg_call(VOID,
+ "__gg__set_exception_call",
+ gg_get_address_of(name.field->var_decl_node),
+ refer_offset(name),
+ NULL_TREE);
parser_exception_raise(ec_program_not_found_e);
if( except )
{
cbl_label_t *not_error );
void parser_accept_command_line_count( const cbl_refer_t &tgt );
-void parser_accept_date_yymmdd( cbl_field_t *tgt );
-void parser_accept_date_yyyymmdd( cbl_field_t *tgt );
-void parser_accept_date_yyddd( cbl_field_t *tgt );
-void parser_accept_date_yyyyddd( cbl_field_t *tgt );
-void parser_accept_date_dow( cbl_field_t *tgt );
-void parser_accept_date_hhmmssff( cbl_field_t *tgt );
+void parser_accept_date_yymmdd( const cbl_refer_t& tgt );
+void parser_accept_date_yyyymmdd( const cbl_refer_t& tgt );
+void parser_accept_date_yyddd( const cbl_refer_t& tgt );
+void parser_accept_date_yyyyddd( const cbl_refer_t& tgt );
+void parser_accept_date_dow( const cbl_refer_t& tgt );
+void parser_accept_date_hhmmssff( const cbl_refer_t& tgt );
void
parser_alphabet( const cbl_alphabet_t *alphabet );
return retval;
}
+FIXED_WIDE_INT(128)
+get_power_of_two(int nbytes)
+ {
+ // This is used for determining if a binary value is truncated as part of a
+ // move to pure binary variable.
+ FIXED_WIDE_INT(128) retval = 1;
+ static const int MAX_POWER = 8 ;
+ static const unsigned long long pos[MAX_POWER+1] =
+ {
+ 1ULL, // 0 byte
+ 256ULL, // 1 bytes
+ 65536ULL, // 2
+ 16777216ULL, // 3
+ 4294967296ULL, // 4
+ 1099511627776ULL, // 5
+ 281474976710656ULL, // 6
+ 72057594037927936ULL, // 7
+ };
+ if( nbytes < MAX_POWER )
+ {
+ retval = pos[nbytes];
+ }
+ else
+ {
+ retval = pos[nbytes];
+ retval *= retval;
+ }
+ return retval;
+ }
+
void
scale_by_power_of_ten_N(tree value,
int N,
void scale_by_power_of_ten_N(tree value,
int N,
bool check_for_fractional = false);
+// cppcheck-suppress unknownMacro
+FIXED_WIDE_INT(128) get_power_of_two(int nbytes);
tree scale_by_power_of_ten(tree value,
tree N,
bool check_for_fractional = false);
if( nul != eol ) {
if( std::any_of( nul, eodata,
[]( char ch ) { return ch != '\0'; } ) ) {
- int icol = nul - cur;
+ int icol = nul - cur; // cppcheck-suppress shadowVariable
fprintf(stderr, "%s:%d:%d: error: NUL character detected in input\n%*s\n",
cobol_filename(), int(iline + 1), ++icol,
int(eol - cur), cur);
&& (destref.field->attr & (signable_e|separate_e|leading_e))
== (sourceref.field->attr & (signable_e|separate_e|leading_e))
&& destref.field->codeset.encoding == sourceref.field->codeset.encoding
+ && !sourceref.refmod.from
+ && !sourceref.refmod.len
+ && !destref.refmod.from
+ && !destref.refmod.len
+ && !sourceref.subscripts.size()
+ && !destref.subscripts.size()
+ && !(sourceref.field->attr & intermediate_e)
+ && !(destref.field->attr & intermediate_e)
+ && !(sourceref.field->attr & any_length_e)
+ && !(destref.field->attr & any_length_e)
)
{
- // These next tests were added because of the DEBUG- registers, which are
- // global external, and most of which have a parent. It turns out that
- // get_location gets flummoxed by that, so we divert it here to the library
- if( sourceref.field->parent
- && sourceref.field->data_decl_node
- && DECL_EXTERNAL(sourceref.field->data_decl_node) )
- {
- return false;
- }
- if( destref.field->parent
- && destref.field->data_decl_node
- && DECL_EXTERNAL(destref.field->data_decl_node) )
- {
- return false;
- }
-
// The source and destination are identical in type and the
// source doesn't have a depending_on clause
SHOW_PARSE1
SHOW_PARSE_INDENT
SHOW_PARSE_TEXT("mh_identical()");
}
- if( refer_is_super_clean(destref)
- && refer_is_super_clean(sourceref) )
- {
- // They are identical, and they have no subscripts
- tree source;
- tree dest;
- get_location(source, sourceref);
- get_location(dest, destref);
+ // They are identical, and they have no refmods or subscripts
+ tree source;
+ tree dest;
+ get_location(source, sourceref);
+ get_location(dest, destref);
- gg_memcpy(dest,
- source,
- build_int_cst_type(SIZE_T,
- destref.field->data.capacity()));
- moved = true;
- }
+ gg_memcpy(dest,
+ source,
+ build_int_cst_type(SIZE_T,
+ destref.field->data.capacity()));
+ moved = true;
}
return moved;
}
bool check_for_error,
const tree &size_error)
{
+ tree value_type = TREE_TYPE(value);
+ tree dest_type = tree_type_from_field(dest);
+
+ if( gg_sizeof(dest_type) > gg_sizeof(value_type) )
+ {
+ // Because the dest_type is greater than the value_type, we don't need to
+ // do any size checking.
+ check_for_error = false;
+ }
+
if( !(dest->attr & signable_e) )
{
gg_assign(value, gg_abs(value));
}
- if( check_for_error )
+ if( check_for_error && dest->data.digits)
{
// We need to see if value can fit into destref
scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
// Create a variable of our target type.
+ tree target = gg_define_variable(dest_type);
+ // Cast the source to the target
+ gg_assign(target, gg_cast(dest_type, value));
+
+ if( check_for_error && !dest->data.digits )
+ {
+ // The destination is pure binary. Make sure we fit:
+ int nbytes = gg_sizeof(dest_type);
+ // We are making sure that value is less than the power of two
+ FIXED_WIDE_INT(128) power_of_two = get_power_of_two(nbytes);
+ tree p_of_two = wide_int_to_tree(value_type, power_of_two);
+
+ IF( value, ge_op, p_of_two )
+ {
+ // Flag the size error
+ gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+
+ tree dest_pointer = gg_define_variable(UCHAR_P);
+ gg_assign(dest_pointer, gg_add(member(dest->var_decl_node, "data"),
+ dest_offset));
+
+ if( dest->type == FldNumericBinary )
+ {
+ // 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,
+ gg_get_address_of(target),
+ build_int_cst_type(SIZE_T, gg_sizeof(dest_type)));
+ }
+
+static void
+copy_intermediate_into_place(cbl_field_t *dest,
+ tree dest_offset,
+ tree value,
+ tree rhs_rdigits,
+ bool check_for_error,
+ const tree &size_error)
+ {
+ // This is just like copy_native_into_place, except that we picked up the
+ // number of rdigits, which isn't a constant, from the intermediate source.
+
+ tree value_type = TREE_TYPE(value);
tree dest_type = tree_type_from_field(dest);
+
+ if( gg_sizeof(dest_type) > gg_sizeof(value_type) )
+ {
+ // Because the dest_type is greater than the value_type, we don't need to
+ // do any size checking.
+ check_for_error = false;
+ }
+
+ if( !(dest->attr & signable_e) )
+ {
+ gg_assign(value, gg_abs(value));
+ }
+
+ if( check_for_error && dest->data.digits )
+ {
+ // We need to see if value can fit into destref
+
+ // We do this by comparing value to 10^(lhs.ldigits + rhs_rdigits)
+ // Example: rhs is 123.45, whichis 12345 with rdigits 2
+ // lhs is 99.999. So, lhs.digits is 5, and lhs.rdigits is 3.
+ // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >= 10000, the
+ // source can't fit into the destination.
+
+ tree abs_value = gg_define_variable(TREE_TYPE(value));
+ gg_assign(abs_value, gg_abs(value));
+
+ tree power_of_ten = gg_define_variable(INT128);
+ gg_assign(power_of_ten,
+ gg_call_expr(INT128,
+ "__gg__power_of_ten",
+ gg_add(build_int_cst_type(INT,
+ dest->data.digits
+ - dest->data.rdigits),
+ gg_cast(INT, rhs_rdigits)),
+ NULL_TREE));
+
+ IF( gg_cast(INT128, abs_value),
+ ge_op,
+ power_of_ten )
+ {
+ // Flag the size error
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ ENDIF
+ }
+ scale_by_power_of_ten(value,
+ gg_subtract(build_int_cst_type(INT, dest->data.rdigits),
+ gg_cast(INT, rhs_rdigits)));
+
+ // Create a variable of our target type.
tree target = gg_define_variable(dest_type);
// Cast the source to the target
gg_assign(target, gg_cast(dest_type, value));
+ if( check_for_error && !dest->data.digits )
+ {
+ // The destination is pure binary. Make sure we fit:
+ int nbytes = gg_sizeof(dest_type);
+ // We are making sure that value is less than the power of two
+ FIXED_WIDE_INT(128) power_of_two = get_power_of_two(nbytes);
+ tree p_of_two = wide_int_to_tree(value_type, power_of_two);
+
+ IF( value, ge_op, p_of_two )
+ {
+ // Flag the size error
+ gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+
tree dest_pointer = gg_define_variable(UCHAR_P);
gg_assign(dest_pointer, gg_add(member(dest->var_decl_node, "data"),
dest_offset));
// This routine moves a numeric value to a binary destination. The dest
// can be little-endian or big-endian.
+ /* In July of 2026, I attempted to create GENERIC for moving intermediates
+ to binaries. It's here, and it can be activated by commenting out the
+ line
+ && !(sourceref.field->attr & (intermediate_e ))
+ But it runs slower than the library version. I didn't attempt to figure
+ out why that is (other things to do!) so I still have the code here. But
+ it isn't being used. Dubner, 2026-07-22 */
+
bool moved = false;
cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.original());
destref.field->data.rdigits,
check_for_error,
size_error);
- moved = true;
}
else
{
- tree source_type = tree_type_from_refer(sourceref);
- tree source;
- get_binary_value(source, sourceref, source_type);
- copy_native_into_place(destref.field,
- refer_offset(destref),
- source,
- sourceref.field->data.rdigits,
- check_for_error,
- size_error);
- moved = true;
+ if( sourceref.field->attr & intermediate_e )
+ {
+ tree source_type = tree_type_from_refer(sourceref);
+ tree source;
+ get_binary_value(source, sourceref, source_type);
+ copy_intermediate_into_place( destref.field,
+ refer_offset(destref),
+ source,
+ member(sourceref.field->var_decl_node,
+ "rdigits"),
+ check_for_error,
+ size_error);
+ }
+ else
+ {
+ tree source_type = tree_type_from_refer(sourceref);
+ tree source;
+ get_binary_value(source, sourceref, source_type);
+ copy_native_into_place( destref.field,
+ refer_offset(destref),
+ source,
+ sourceref.field->data.rdigits,
+ check_for_error,
+ size_error);
+ }
}
+ moved = true;
}
return moved;
}
moved = mh_to_binary( destref,
sourceref,
tsource,
- restore_on_error,
+ check_for_error,
size_error);
}
{
IF(size_error, ne_op, integer_zero_node)
{
- // We had a size error, but there was no restore_on_error. Pointer
+ // We had a size error, but there was no restore_on_error.
// Let our lord and master know there was a truncation:
set_exception_code(ec_size_truncation_e);
}
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_yymmdd($r->field);
+ parser_accept_date_yymmdd(*$r);
}
| ACCEPT scalar[r] FROM DATE YYYYMMDD
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_yyyymmdd($r->field);
+ parser_accept_date_yyyymmdd(*$r);
}
| ACCEPT scalar[r] FROM DAY
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_yyddd($r->field);
+ parser_accept_date_yyddd(*$r);
}
| ACCEPT scalar[r] FROM DAY YYYYDDD
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_yyyyddd($r->field);
+ parser_accept_date_yyyyddd(*$r);
}
| ACCEPT scalar[r] FROM DAY_OF_WEEK
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_dow($r->field);
+ parser_accept_date_dow(*$r);
}
| ACCEPT scalar[r] FROM TIME
{
statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $r->is_reference() ) {
- error_msg(@1, "subscripts are unsupported here");
- YYERROR;
- }
- parser_accept_date_hhmmssff($r->field);
+ parser_accept_date_hhmmssff(*$r);
}
| ACCEPT scalar[r] FROM acceptable
{
| device_name[dev]
{
auto dev = symbol_special($dev.id);
+ error_msg(@dev, "invalid device %qs: FD name required", dev->name);
+ YYERROR;
auto e = symbol_file(PROGRAM, dev->name);
if( ! e ) {
error_msg(@dev, "no FD selected for device '%s'", dev->name);
**/
static cbl_field_t debug_registers[] = {
- { FldGroup, register_e,
+ { FldGroup, external_e|register_e,
{132,132,0,0, NULL}, 1, "DEBUG-ITEM", cp1252 },
- { FldAlphanumeric, register_e,
+ { FldAlphanumeric, external_e|register_e,
{6,6,0,0, " "}, 2, "DEBUG-LINE", cp1252 },
- { FldAlphanumeric, register_e|filler_e,
+ { FldAlphanumeric, external_e|register_e|filler_e,
{1,1,0,0, " "}, 2, "FILLER", cp1252 },
- { FldAlphanumeric, register_e,
+ { FldAlphanumeric, external_e|register_e,
{30,30,0,0, NULL}, 2, "DEBUG-NAME", cp1252 },
- { FldAlphanumeric, register_e|filler_e,
+ { FldAlphanumeric, external_e|register_e|filler_e,
{1,1,0,0, " "}, 2, "FILLER", cp1252 },
- { FldNumericDisplay, signable_e | register_e | leading_e | separate_e,
+ { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e,
{5,5,4,0, NULL}, 2, "DEBUG-SUB-1", cp1252 },
- { FldAlphanumeric, register_e|filler_e,
+ { FldAlphanumeric, external_e|register_e|filler_e,
{1,1,0,0, " "}, 2, "FILLER", cp1252 },
- { FldNumericDisplay, signable_e | register_e | leading_e | separate_e,
+ { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e,
{5,5,4,0, NULL}, 2, "DEBUG-SUB-2", cp1252 },
- { FldAlphanumeric, register_e|filler_e,
+ { FldAlphanumeric, external_e|register_e|filler_e,
{1,1,0,0, " "}, 2, "FILLER", cp1252 },
- { FldNumericDisplay, signable_e | register_e | leading_e | separate_e,
+ { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e,
{5,5,4,0, NULL}, 2, "DEBUG-SUB-3", cp1252 },
- { FldAlphanumeric, register_e | filler_e,
+ { FldAlphanumeric, external_e|register_e | filler_e,
{1,1,0,0, " "}, 2, "FILLER", cp1252 },
- { FldAlphanumeric, register_e,
+ { FldAlphanumeric, external_e|register_e,
{76,76,0,0, NULL}, 2, "DEBUG-CONTENTS", cp1252 },
};
static const struct cbl_field_t empty_comp5 = {
FldNumericBin5,
signable_e | intermediate_e,
- {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL} };
+ {16, 16, 0, 0, NULL} };
static const struct cbl_field_t empty_conditional = {
FldConditional, intermediate_e, cbl_field_data_t{} };
static struct cbl_field_t empty_literal = {
*/
struct funcname {
std::string output;
- funcname( const char name[] ) {
+ funcname( const char name[] ) { // cppcheck-suppress noExplicitConstructor
auto ename = name + strlen(name);
auto p = std::find(name, ename, ' ');
p = p == ename? name : p + 1;
{
output.type = FldNumericBin5;
output.data.capacity(16);
- output.data.digits = MAX_FIXED_POINT_DIGITS;
output.attr = (intermediate_e | signable_e );
}
--- /dev/null
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 dates.
+ 02 foo pic x(30) occurs 6 times.
+ 01 msg pic x(20) value "The year is xxxx CE." .
+ procedure division.
+ display "GCOBOL_CURRENT_DATE" upon environment-name
+ display "19530227123456" upon environment-value
+ accept foo(1) from time
+ accept foo(2) from date
+ accept foo(3) from date yyyymmdd
+ accept foo(4) from day
+ accept foo(5) from day yyyyddd
+ accept foo(6) from day-of-week
+ display function trim(foo(1))
+ display function trim(foo(2))
+ display function trim(foo(3))
+ display function trim(foo(4))
+ display function trim(foo(5))
+ display function trim(foo(6))
+ accept msg(13:4) from date yyyymmdd
+ display msg
+ goback.
+ end program prog.
+
--- /dev/null
+12345600
+530227
+19530227
+53058
+1953058
+5
+The year is 1953 CE.
+
--- /dev/null
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/MOVE__identical__operations.out" }
+ program-id. bugger.
+ data division.
+ working-storage section.
+ 01 debug-contents-e pic x(76) external.
+ 01 debug-contents-b pic x(76) based .
+ 01 debug-contents-w pic x(76) .
+ procedure division.
+ allocate debug-contents-b.
+ move "telephone-1" to debug-contents
+ move debug-contents to debug-contents-b
+ move debug-contents-b to debug-contents-e
+ move debug-contents-e to debug-contents-w
+ display "start with " function trim(debug-contents-e)
+ call "bug" using debug-contents-w
+ display "end with " function trim(debug-contents-e)
+ goback.
+ end program bugger.
+ *>
+ program-id. bug.
+ data division.
+ working-storage section.
+ 01 debug-contents-e pic x(76) external.
+ 01 debug-contents-w2 pic x(76).
+ linkage section.
+ 01 dc.
+ 10 debug-contents-l pic x(76).
+ procedure division using dc.
+ move debug-contents-l to debug-contents-w2
+ string function trim(debug-contents-w2) " - modified" into debug-contents-e
+ goback.
+
--- /dev/null
+start with telephone-1
+end with telephone-1 - modified
+
--- /dev/null
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-ffixed-form -copyext copy -I." }
+
+ >>source format is free
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. fail.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION LENGTH TRIM INTRINSIC.
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD.".
+ END PROGRAM fail.
+
.parent = NULL ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = register_e ,
+ .attr = external_e | register_e ,
.type = FldGroup ,
.level = 01 ,
.digits = 0 ,
.parent = &__ggsr__debug_item ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = register_e ,
+ .attr = external_e | register_e ,
.type = FldAlphanumeric ,
.level = 05 ,
.digits = 0 ,
.parent = &__ggsr__debug_item ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = register_e | filler_e ,
+ .attr = external_e | register_e | filler_e ,
.type = FldAlphanumeric ,
.level = 05 ,
.digits = 0 ,
.parent = &__ggsr__debug_item ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = register_e ,
+ .attr = external_e | register_e ,
.type = FldAlphanumeric ,
.level = 05 ,
.digits = 0 ,
.parent = &__ggsr__debug_item ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = register_e | filler_e ,
+ .attr = external_e | register_e | filler_e ,
.type = FldAlphanumeric ,
.level = 05 ,
.digits = 0 ,
.parent = &__ggsr__debug_item ,
.occurs_lower = 0 ,
.occurs_upper = 0 ,
- .attr = signable_e | register_e | leading_e | separate_e ,
+ .attr = signable_e | external_e | register_e | leading_e | separate_e ,
.type = FldNumericDisplay ,
.level = 05 ,
.digits = 4 ,
static const char *last_exception_source_file;
static int last_exception_line_number;
static const char *last_exception_statement;
+// last_exception_call is a special case. It gets set immediately before the
+// default_exception_handler is invoked, so it's followed immediately by an
+// abort().
+static const char *last_exception_call;
// These variables are similar, and are established when an exception is
// raised for a file I-O operation.
static cblc_file_prior_op_t last_exception_file_operation;
}
static void
-field_from_ascii(cblc_field_t *field, char *psz)
+field_from_ascii(cblc_field_t *field,
+ size_t offset,
+ size_t length,
+ char *psz)
{
cblc_field_t source = {};
source.type = FldAlphanumeric;
source.capacity = strlen(psz);
source.data = as_unsigned_chars(psz);
source.encoding = __gg__console_encoding;
- __gg__move( field, field->offset, field->capacity,
- &source, source.offset, source.capacity,
- 0, truncation_e );
+ __gg__move( field,
+ offset,
+ length,
+ &source,
+ source.offset,
+ source.capacity,
+ 0,
+ truncation_e );
}
extern "C"
void
-__gg__get_date_yymmdd(cblc_field_t *field)
+__gg__get_date_yymmdd(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
local->tm_year % 100,
local->tm_mon+1 % 100,
local->tm_mday % 100 );
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
extern "C"
void
-__gg__get_date_yyyymmdd(cblc_field_t *field)
+__gg__get_date_yyyymmdd(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
time_t t = cobol_time();
local->tm_year + 1900,
local->tm_mon+1,
local->tm_mday);
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
extern "C"
void
-__gg__get_date_yyddd(cblc_field_t *field)
+__gg__get_date_yyddd(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
"%2.2d%3.3d",
local->tm_year % 100,
local->tm_yday+1);
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
extern "C"
void
-__gg__get_yyyyddd(cblc_field_t *field)
+__gg__get_yyyyddd(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
"%4.4d%3.3d",
local->tm_year + 1900,
local->tm_yday+1);
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
extern "C"
void
-__gg__get_date_dow(cblc_field_t *field)
+__gg__get_date_dow(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
sprintf(ach,
"%1.1d",
local->tm_wday == 0 ? 7 : local->tm_wday);
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
static int
extern "C"
void
-__gg__get_date_hhmmssff(cblc_field_t *field)
+__gg__get_date_hhmmssff(cblc_field_t *field, size_t offset, size_t length)
{
char ach[32];
struct cbl_timespec tv;
tm.tm_min,
tm.tm_sec,
hundredths);
- field_from_ascii(field, ach);
+ field_from_ascii(field, offset, length, ach);
}
static
const unsigned char *digits_e;
// This is the running index into our output destination.
int index = 0;
- bool is_negative;
+ bool is_negative=false;
switch(signtype)
{
assert( ec_status.is_enabled(ec) );
}
+ if( !filename && last_exception_call) {
+ char *callname = strdup(last_exception_call);
+ massert(callname);
+ char *p = callname+strlen(callname)-1;
+ while(p >= callname)
+ {
+ if( *p != ascii_space )
+ {
+ break;
+ }
+ *p-- = '\0';
+ }
+ filename = callname;
+ }
+
switch( disposition ) {
case ec_category_none_e:
case uc_category_none_e:
last_exception_paragraph = NULL ;
last_exception_source_file = NULL ;
last_exception_line_number = 0 ;
+ last_exception_call = NULL ;
last_exception_statement = NULL ;
last_exception_file_operation = file_op_none ;
last_exception_file_status = FsSuccess ;
return;
}
+extern "C"
+void
+__gg__set_exception_call(const cblc_field_t *field,
+ size_t offset)
+ {
+ size_t nbytes;
+ cbl_encoding_t enc = field->encoding;
+ if( field->encoding == custom_encoding_e)
+ {
+ enc = DEFAULT_SOURCE_ENCODING;
+ }
+ last_exception_call = __gg__miconverter(enc,
+ DEFAULT_SOURCE_ENCODING,
+ field->data + offset,
+ field->capacity,
+ &nbytes);
+ }
projects / thirdparty / gcc.git / commitdiff
