## output set the mode variable. Everything else is appended to the
## opts variable.
##
-## - -fPIC is added to the command line if $mode is "-shared". That
-## option applies only to "certain machines", per the gcc info
-## manual. For this script to be portable across machines, -fPIC
-## would have to be set more judiciously.
+## - -fPIC is added to the command line unless we're producing an
+## executable. That option applies only to "certain machines", per
+## the gcc info manual. For this script to be portable across
+## machines, -fPIC would have to be set more judiciously.
+
+# To override the default gcobol, set the "gcobol" environment variable.
+gcobol="${gcobol:-${0%/*}/gcobol}"
+
+# If invoked as "gcobcx", execute with tracing enabled.
+if [ gcobcx = ${0##*/} ]
+then
+ #cho "parsing args: $@" >&2
+ set -x
+fi
if [ "$COBCPY" ]
then
exit_status=0
skip_arg=
opts="$copydir $includes"
+cflags=-fPIC
mode=-shared
incomparable="has no comparable gcobol option"
continue
fi
+ #cho "next arg: $opt" >&2
+
case $opt in
# pass next parameter to GCC
-D)
pending_arg=$opt
;;
- -E) opts="$opts $opt -fsyntax-only"
- ;;
- -echo) echo="echo"
+ -E) opts="$opts $opt -fsyntax-only"
+ ;;
+ -echo) echo="echo"
;;
-fec=* | -fno-ec=*)
;;
-i | --info) warn "$opt"
;;
- -I) pending_arg=$opt
+ -include )
+ pending_arg=$opt
+ ;;
+ # no-space version: just concatenate
+ -include* )
+ opts="$opts $opt"
+ ;;
+ #
+ # Options that may have a space before the argument, or not
+ #
+ -I | -L | -MF | -MT )
+ pending_arg=$opt
;;
- -I*)
+ # no-space version: just concatenate
+ -I* | -L* | -MF* | -MT* )
opts="$opts $opt"
;;
+
-fimplicit-init) warn "$opt"
;;
-j | -job) warn "$opt"
-K*) warn "$opt"
;;
# -l
- -L) pending_arg=$opt
- ;;
--list*) warn "$opt"
;;
-m) mode="-shared"
-v | --verbose) opts="$opts -V"
;;
# note: we want -dumpversion to be passed to gcc
- -V | --version | -version) opts="$opts --version"
+ -V | --version | -version)
+ $gcobol --version |
+ awk '1 == NR { ver = $3;
+ $3 = "3.1"
+ $5 = "(GnuCOBOL emulation using " ver ")" } 1'
+ exit
+ # opts="$opts --version"
;;
# pass through, strangely -Wall is not supported
-w | -W | -Wextra) opts="$opts $opt"
-Wno-*) no_warn "$opt"
;;
- -W*) ignore_arg "$opt"
+ -W*) warn "$opt"
;;
-x) mode=
+ cflags=
;;
-) output_name=a.out # nonnull to prevent overriding gcc default
;;
-shared)
output_name="$output_name".so
- opts="$opts -fPIC"
;;
esac
- opts="$opts -o $output_name"
+ opts="$opts $cflags -o $output_name"
fi
opts="$opts $opt" # pass through
;;
# cobc default:
if [ "$static_used" = "" ]
then
- opts="$opts -fno-static-call";
+ opts="-fno-static-call $opts";
fi
if [ "$exit_status" -gt 0 ]
exit $exit_status
fi
-# To override the default gcobol, set the "gcobol" environment variable.
-gcobol="${gcobol:-${0%/*}/gcobol}"
-
if [ "$dialect" ]
then
dialect=$(echo $dialect | sed -E 's/[[:alnum:]]+/-dialect &/g')
- .ds lang COBOL
+.ds lang COBOL
.ds gcobol GCC\ \*[lang]\ Front-end
.ds isostd ISO/IEC 1989:2023
.Dd \& February 2025
.It Fl Wno-apply-commit
Warn if APPLY COMMIT is used.
.It Fl Wno-bad-line-directive
-Warn if malformed %<#line%> directive is encountered.
+Warn if malformed
+.Ql #line
+directive is encountered.
.It Fl Wno-binary-long-long
Warn if BINARY-LONG-LONG is used.
.It Fl Wno-call_giving
.It
ABS ACOS ANNUITY ASIN ATAN
.It
-BASECONVERT BIT-OF BIT-TO-CHAR BOOLEAN-OF-INTEGER BYTE-LENGTH
+BASECONVERT \%BIT-OF \%BIT-TO-CHAR \%BOOLEAN-OF-INTEGER \%BYTE-LENGTH
.It
-CHAR CHAR-NATIONAL COMBINED-DATETIME CONCAT CONVERT COS CURRENT-DATE
+CHAR \%CHAR-NATIONAL \%COMBINED-DATETIME CONCAT CONVERT COS \%CURRENT-DATE
.It
-DATE-OF-INTEGER DATE-TO-YYYYMMDD DAY-OF-INTEGER DAY-TO-YYYYDDD DISPLAY-OF
+\%DATE-OF-INTEGER \%DATE-TO-YYYYMMDD \%DAY-OF-INTEGER \%DAY-TO-YYYYDDD \%DISPLAY-OF
.It
-E EXCEPTION-FILE
-EXCEPTION-FILE-N EXCEPTION-LOCATION EXCEPTION-LOCATION-N
-EXCEPTION-STATEMENT EXCEPTION-STATUS EXP EXP10
+E \%EXCEPTION-FILE
+\%EXCEPTION-FILE-N \%EXCEPTION-LOCATION \%EXCEPTION-LOCATION-N
+\%EXCEPTION-STATEMENT \%EXCEPTION-STATUS EXP EXP10
.It
-FACTORIAL FIND-STRING
-FORMATTED-CURRENT-DATE FORMATTED-DATE FORMATTED-DATETIME
-FORMATTED-TIME FRACTION-PART
+FACTORIAL \%FIND-STRING
+\%FORMATTED-CURRENT-DATE \%FORMATTED-DATE \%FORMATTED-DATETIME
+\%FORMATTED-TIME \%FRACTION-PART
.It
-HEX-OF HEX-TO-CHAR HIGHEST-ALGEBRAIC
+\%HEX-OF \%HEX-TO-CHAR \%HIGHEST-ALGEBRAIC
.It
-INTEGER INTEGER-OF-BOOLEAN INTEGER-OF-DATE INTEGER-OF-DAY
-INTEGER-OF-FORMATTED-DATE INTEGER-PART
+INTEGER \%INTEGER-OF-BOOLEAN \%INTEGER-OF-DATE \%INTEGER-OF-DAY
+\%INTEGER-OF-FORMATTED-DATE \%INTEGER-PART
.It
-LENGTH LOCALE-COMPARE
-LOCALE-DATE LOCALE-TIME LOCALE-TIME-FROM-SECONDS LOG LOG10 LOWER-CASE
-LOWEST-ALGEBRAIC
+LENGTH \%LOCALE-COMPARE
+\%LOCALE-DATE \%LOCALE-TIME \%LOCALE-TIME-FROM-SECONDS LOG LOG10 \%LOWER-CASE
+\%LOWEST-ALGEBRAIC
.It
-MAX MEAN MEDIAN MIDRANGE MIN MOD MODULE-NAME
+MAX MEAN MEDIAN MIDRANGE MIN MOD \%MODULE-NAME
.It
-NATIONAL-OF NUMVAL NUMVAL-C NUMVAL-F ORD
+\%NATIONAL-OF NUMVAL \%NUMVAL-C \%NUMVAL-F ORD
.It
-ORD-MAX ORD-MIN
+\%ORD-MAX \%ORD-MIN
.It
-PI PRESENT-VALUE
+PI \%PRESENT-VALUE
.It
RANDOM RANGE REM REVERSE
.It
-SECONDS-FROM-FORMATTED-TIME
-SECONDS-PAST-MIDNIGHT SIGN SIN SMALLEST-ALGEBRAIC SQRT
-STANDARD-COMPARE STANDARD-DEVIATION SUBSTITUTE SUM
+\%SECONDS-FROM-FORMATTED-TIME
+\%SECONDS-PAST-MIDNIGHT SIGN SIN \%SMALLEST-ALGEBRAIC SQRT
+\%STANDARD-COMPARE \%STANDARD-DEVIATION SUBSTITUTE SUM
.It
-TAN TEST-DATE-YYYYMMDD TEST-DAY-YYYYDDD TEST-FORMATTED-DATETIME
-TEST-NUMVAL TEST-NUMVAL-C TEST-NUMVAL-F TRIM
+TAN \%TEST-DATE-YYYYMMDD \%TEST-DAY-YYYYDDD \%TEST-FORMATTED-DATETIME
+\%TEST-NUMVAL \%TEST-NUMVAL-C \%TEST-NUMVAL-F TRIM
.It
-ULENGTH UPOS UPPER-CASE
+ULENGTH UPOS \%UPPER-CASE
USUBSTR USUPPLEMENTARY UUID4 UVALID UWIDTH
.It
VARIANCE
.It
-WHEN-COMPILED
+\%WHEN-COMPILED
.It
-YEAR-TO-YYYY
+\%YEAR-TO-YYYY
.El
.
.Ss Binary floating point DISPLAY
sv_is_i_o = false;
}
+void
+parser_statement_end( const std::list<cbl_field_t*>&flist)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char *psz = xasprintf(" List has %ld elements", flist.size());
+ SHOW_PARSE_TEXT(psz);
+ free(psz);
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ char *psz = xasprintf(" List has %ld elements", flist.size());
+ TRACE1_TEXT(psz);
+ free(psz);
+ TRACE1_END
+ }
+ if( flist.size() )
+ {
+ for( auto field : flist )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char *psz = xasprintf("Deallocating %s", field->name);
+ SHOW_PARSE_TEXT(psz);
+ free(psz);
+ }
+ TRACE1
+ {
+ TRACE1_INDENT
+ char *psz = xasprintf(" Deallocating %s", field->name);
+ TRACE1_TEXT(psz);
+ free(psz);
+ }
+
+ gg_free(member(field->var_decl_node, "data"));
+ // Flag this guy as free:
+ gg_assign(member(field->var_decl_node, "data"), gg_cast(UCHAR_P, null_pointer_node));
+ gg_assign(member(field->var_decl_node, "allocated"), gg_cast(SIZE_T, integer_zero_node));
+ }
+ TRACE1
+ {
+ TRACE1_END
+ }
+ }
+ }
+
static void
initialize_variable_internal( cbl_refer_t refer,
bool explicitly=false,
return;
}
- if( parsed_var->attr & register_e )
+ if( parsed_var->attr & register_e
+ || ( parsed_var->attr & intermediate_e
+ && parsed_var->type == FldAlphanumeric) )
{
return;
}
// Let's check for the simplified case where both left and right sides are
// little-endian binary values:
-
+
if( is_pure_integer(left_side_ref->field)
&& is_pure_integer(right_side_ref->field) )
{
} label_verify;
void
-parser_end_program(const char *prog_name )
+parser_end_program(const char *prog_name )
{
if( gg_trans_unit.function_stack.size() )
{
"__gg__variables_to_init",
gg_get_address_of(array),
wsclear() ? build_string_literal(
- 1,
+ 1,
reinterpret_cast<const char *>(wsclear()))
: null_pointer_node,
NULL_TREE);
}
void
-parser_exit_program(void) // exits back to COBOL only, else continue
- {
+parser_exit_program()
+ { // exits back to COBOL only, else continue
static cbl_label_t this_program = {};
static cbl_refer_t magic_refer(&this_program, false);
parser_exit( magic_refer );
static
void
-program_end_stuff(cbl_refer_t refer, ec_type_t ec)
+program_end_stuff(cbl_refer_t refer,
+ ec_type_t ec)
{
// This is the moral equivalent of a C "return xyz;".
}
void
-parser_exit( const cbl_refer_t& refer, ec_type_t ec )
+parser_exit( const cbl_refer_t& refer,
+ ec_type_t ec )
{
Analyze();
SHOW_PARSE
// The next instructions that the parser will give us are the conditional
// calculation, so the first thing that goes down is the condover:
- /* The following NOP is needed to make NEXT OVER PERFORM BEFORE/AFTER UNTIL
+ /* The following NOP is needed to make NEXT OVER PERFORM BEFORE/AFTER UNTIL
behaves properly. */
insert_nop(106);
gg_append_statement(tgt->addresses.condover[i].go_to);
create_iline_address_pairs(tgt);
// Tag the top of the perform
-
+
gg_append_statement(tgt->addresses.top.label);
// Go do the conditional calculation:
}
if( varies.max < symbol_file_record(file)->data.capacity())
{
- const charmap_t *charmap =
+ const charmap_t *charmap =
__gg__get_charmap(current_encoding(display_encoding_e));
varies.min *= charmap->stride();
varies.max *= charmap->stride();
if( ( destref.field->type == FldAlphanumeric
|| destref.field->type == FldGroup )
&& !(destref.field->attr & any_length_e)
- && !sourceref.all
+ && !sourceref.all
&& !size_error)
{
// A simple alpha-to-alpha move is possible
&& new_var->type != FldLiteralA
&& new_var->type != FldLiteralN )
{
-// new_var_decl = gg_define_variable( cblc_field_type_node,
-// base_name,
-// vs_static);
+ gg_variable_scope_t scope = vs_stack;
+ if( new_var->type == FldAlphanumeric )
+ {
+ // This has to be static, because we are putting the actual memory
+ // on the heap. But if we put the cblc_field_t on the stack inside
+ // of a condition, or in a loop, we just keep recreating the field
+ // without getting freeing the memory. Eventually, with perhaps a
+ // two-pass compiler, we'll be able to create the stack cblc_field_t
+ // once per program-id.
+ scope = vs_static;
+ }
new_var_decl = gg_define_variable( cblc_field_type_node,
base_name,
- vs_stack);
+ scope);
SET_DECL_MODE(new_var_decl, BLKmode);
}
else
|| new_var->type == FldLiteralA
)
{
- if( new_var->data.initial && new_var->data.capacity() )
+ if( new_var->data.initial
+ && new_var->data.capacity()
+ && !(new_var->attr & intermediate_e) )
{
SHOW_PARSE_INDENT
for(size_t i=0; i<new_var->data.capacity(); i++)
if( new_var->var_decl_node )
{
- if( new_var->type != FldConditional )
- {
- // There is a possibility when re-using variables that a temporary that
- // was created at compile time might not have a data pointer at run time.
- if( new_var->attr & (intermediate_e) )
- {
- IF( member(new_var->var_decl_node, "allocated"),
- lt_op,
- member(new_var->var_decl_node, "capacity") )
- {
- gg_free(member(new_var, "data"));
- gg_assign(member(new_var, "data"),
- gg_cast(UCHAR_P, gg_malloc(new_var->data.capacity())));
- gg_assign(member(new_var, "allocated"),
- build_int_cst_type(SIZE_T, new_var->data.capacity()));
- }
- ELSE
- {
- }
- ENDIF
- }
- }
- else
+ if( new_var->type == FldConditional )
{
gg_assign(new_var->var_decl_node, boolean_false_node);
}
* 4. cbl_field_data_t::capacity is 0 because it requires no working storage
*/
- if( new_var->data.capacity() == 0
+ if( new_var->data.capacity() == 0
+ && !( new_var->type == FldAlphanumeric
+ && new_var->attr & intermediate_e)
&& new_var->level != 88
&& new_var->type != FldClass
&& new_var->type != FldLiteralN
bytes_to_allocate = 1;
}
- if( !bytes_to_allocate )
+ if( !bytes_to_allocate && !(new_var->attr & intermediate_e) )
{
cbl_internal_error( "%<bytes_to_allocate%> is zero for %s (symbol number "
HOST_SIZE_T_PRINT_DEC ")",
}
}
- if( bytes_to_allocate )
+ if( new_var->attr & intermediate_e
+ && new_var->type == FldAlphanumeric )
{
- // We need a unique name for the allocated data for this COBOL variable:
- char achDataName[256];
- if( new_var->attr & external_e )
- {
- sprintf(achDataName, "%s", new_var->name);
- }
- else if( new_var->name[0] == '_' )
- {
- // Avoid doubling up on leading underscore
- sprintf(achDataName,
- "%s_data_" HOST_SIZE_T_PRINT_UNSIGNED,
- new_var->name,
- (fmt_size_t)sv_data_name_counter++);
- }
- else
+ // We don't allocate here for intermediates. We instead use
+ // malloc() in the library when a run-time value is assigned to this
+ // variable
+ data_area = null_pointer_node;
+ }
+ else
+ {
+ if( bytes_to_allocate )
{
- sprintf(achDataName,
- "_%s_data_" HOST_SIZE_T_PRINT_UNSIGNED,
- new_var->name,
- (fmt_size_t)sv_data_name_counter++);
- }
+ // We need a unique name for the allocated data for this COBOL variable:
+ char achDataName[256];
+ if( new_var->attr & external_e )
+ {
+ sprintf(achDataName, "%s", new_var->name);
+ }
+ else if( new_var->name[0] == '_' )
+ {
+ // Avoid doubling up on leading underscore
+ sprintf(achDataName,
+ "%s_data_" HOST_SIZE_T_PRINT_UNSIGNED,
+ new_var->name,
+ (fmt_size_t)sv_data_name_counter++);
+ }
+ else
+ {
+ sprintf(achDataName,
+ "_%s_data_" HOST_SIZE_T_PRINT_UNSIGNED,
+ new_var->name,
+ (fmt_size_t)sv_data_name_counter++);
+ }
- if( new_var->attr & external_e )
- {
- tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
- new_var->data_decl_node = gg_define_variable(
- array_type,
- achDataName,
- vs_external);
- data_area = gg_get_address_of(new_var->data_decl_node);
- }
- else
- {
- gg_variable_scope_t vs_scope = (new_var->attr & intermediate_e)
- ? vs_stack : vs_static ;
- tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
- new_var->data_decl_node = gg_define_variable(
- array_type,
- achDataName,
- vs_scope);
- data_area = gg_get_address_of(new_var->data_decl_node);
+ if( new_var->attr & external_e )
+ {
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_external);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
+ else
+ {
+ gg_variable_scope_t vs_scope = (new_var->attr & intermediate_e)
+ ? vs_stack : vs_static ;
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_scope);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
}
}
}
void
parser_program_hierarchy( const struct cbl_prog_hier_t& hier );
void
-parser_end_program(const char *name=NULL);
+parser_end_program(const char *name);
void parser_sleep(const cbl_refer_t &seconds);
-void parser_exit( const cbl_refer_t& refer, ec_type_t = ec_none_e );
+void parser_exit( const cbl_refer_t& refer,
+ ec_type_t = ec_none_e );
void parser_exit_section(void);
void parser_exit_paragraph(void);
void parser_exit_perform( struct cbl_perform_tgt_t *tgt, bool cycle );
-void parser_exit_program(void); // exits back to COBOL only, else continue
+void parser_exit_program(); // exits back to COBOL only, else continue
void
parser_exhibit( bool changed, bool named,
tree file_static_variable(tree type, const char *name);
void parser_statement_begin( const cbl_name_t name, tree ecs, tree dcls );
+void parser_statement_end( const std::list<cbl_field_t*>& );
tree parser_compile_ecs( const std::vector<uint64_t>& ecs );
tree parser_compile_dcls( const std::vector<uint64_t>& dcls );
#include "copybook.h"
#include "lexio.h"
+#include <iostream>
+
extern int yy_flex_debug;
source_format_t& cdf_source_format();
parse_replace_pairs( const char *stmt, const char *estmt, bool is_copy_stmt ) {
std::list<replace_t> pairs ;
- static const char any_ch[] = ".";
- static const char word_ch[] = "[[:alnum:]$_-]";
+ static const char any_ch[] = "";
+ //// const char word_ch[] = "[[:alnum:]$_-]";
static const char nonword_ch[] = "[^[:alnum:]\"'$_-]";
// Pattern to find one REPLACE pseudo-text pair
if( parsed.leading_trailing.size() > 0 ) {
switch( TOUPPER(parsed.leading_trailing.p[0]) ) {
case 'L': // leading
- befter[1] = word_ch;
+ befter[1] = any_ch;
break;
case 'T': // trailing
- befter[0] = word_ch;
+ befter[0] = any_ch;
break;
default:
gcc_unreachable();
if( input == -1 ) return NULL;
int output = open_output();
-
+ size_t n =0;
+
// Process any files supplied by the -include command-line option.
for( auto name : included_files ) {
+ int input; // cppcheck-suppress shadowVariable
if( -1 == (input = open(name, O_RDONLY)) ) {
cbl_message(LexIncludeE, "cannot open %<-include%> file %qs", name);
continue;
}
+ dbgmsg("lex_open: including %zu of %zu: '%s'", ++n, included_files.size(), name);
cobol_filename(name, inode_of(input));
filespan_t mfile( free_form_reference_format( input ) );
process_file( mfile, output );
+ dbgmsg("lex_open: processed %zu of %zu: '%s'", n, included_files.size(), name);
cobol_filename_restore(); // process_file restores only for COPY
}
included_files.clear();
+ dbgmsg("lex_open: '%s'", filename);
cobol_filename(filename, inode_of(input));
filespan_t mfile( free_form_reference_format( input ) );
// parse CDF directives
while( mfile.next_line() ) {
+ if( false ) {
+ std::string line( mfile.ccur(), const_cast<const char *>(mfile.eol) );
+ std::cerr << __func__ << ": "
+ << mfile.lineno() << ":" << mfile.colno() << ": "
+ << line;
+ }
yylloc = mfile.as_location();
auto copied = parse_copy_directive(mfile);
if( copied.parsed && copied.fd != -1 ) {
%type <field> log_term rel_expr rel_abbr eval_abbr
%type <refer> num_value num_term value factor
-%type <refer> simple_cond bool_expr
+%type <refer> simple_cond bool_expr until_expr
%type <log_expr_t> log_expr rel_abbrs eval_abbrs
%type <rel_term_t> rel_term rel_term1
// Check COMP-5 capacity
// No capacity means no PICTURE, valid only for a (potential) group
- if( $field->type == FldNumericBin5 ) {
+ if( is_among( $field->type, {FldNumericBinary, FldNumericBin5} ) ) {
if( $field->data.capacity() == 0 ) {
if( has_clause ($data_clauses, usage_clause_e) &&
!has_clause ($data_clauses, picture_clause_e) ) {
}
assert(0 < $nchar);
field->data.picture = nullptr;
- auto nchar = std::min($nchar, MAXIMUM_ALPHA_LENGTH);
- if( nchar < $nchar ) {
+ auto nchar = std::min(size_t($nchar), MAXIMUM_ALPHA_LENGTH);
+ if( nchar < size_t($nchar) ) {
error_msg(@2, "alphanumeric data-item size (%d) "
- "exceeds maximum of %d bytes",
- $nchar, MAXIMUM_ALPHA_LENGTH);
+ "exceeds maximum of %lu bytes",
+ $nchar, (unsigned long)MAXIMUM_ALPHA_LENGTH);
}
field->set_initial(nchar, @nchar);
}
}
}
}
- | VALUE all cce_expr[cce] {
+ | VALUE all const_value[cce] {
/*
* cce has two parts:
* cce.r) Host binary value
}
| VALUE error
{
- error_msg(@2, "invalid VALUE");
+ if( 0 < yychar ) {
+ error_msg(@2, "invalid VALUE at %qs", keyword_str(yychar));
+ } else {
+ error_msg(@2, "invalid VALUE");
+ }
}
;
}
;
-statements: statement { $$ = $1; }
- | statements statement { $$ = $2; }
+statements: statement {
+ $$ = $1;
+ parser_statement_end( symbol_temporary_alphanumerics() );
+ }
+ | statements statement {
+ $$ = $2;
+ parser_statement_end( symbol_temporary_alphanumerics() );
+ }
;
statement: error {
$$ = new_reference(new_temporary(FldConditional));
parser_relop($$->field, lhs, eq_op, rhs);
}
- | expr NOT OMITTED
- {
+ | expr /* IS */ NOT OMITTED
+ { // IS captured by lexer
auto lhs = cbl_refer_t($expr->field);
lhs.addr_of = true;
auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
}
;
+until_expr: bool_expr
+ | EXIT {
+ auto e = symbol_at(very_true_register());
+ $$ = new_reference(cbl_field_of(e));
+ }
+ ;
+
bool_expr: log_expr { $$ = new_reference($1->resolve()); }
;
}
;
perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); }
- bool_expr
+ until_expr[expr]
{
parser_perform_conditional_end( &perform_current()->tgt);
- if( !is_conditional($bool_expr) ) {
+ if( !is_conditional($expr) ) {
error_msg(@1, "%s is not a condition expression",
- name_of($bool_expr->field));
+ name_of($expr->field));
YYERROR;
}
- $$ = $bool_expr->cond();
+ $$ = $expr->cond();
}
;
cbl_refer_t *r = new_reference(new_literal(@1, $1, quoted_e));
$$ = new cbl_ffi_arg_t(by_content_e, r);
}
+ | num_literal
+ {
+ cbl_message(@1, MfCallLiteral,
+ "cannot pass %qs BY REFERENCE", $1->data.initial);
+ cbl_refer_t *r = new_reference($1);
+ $$ = new cbl_ffi_arg_t(by_content_e, r);
+ }
| ADDRESS OF scalar_arg[refer]
{
$$ = new cbl_ffi_arg_t(by_reference_e, $refer, address_of_e);
keyword_str($1), (long)(p - args.data()), name_of(p->field) );
YYERROR;
}
- $$ = is_numeric(args[0].field)?
- new_tempnumeric_float() :
- new_alphanumeric();
+ $$ = intrinsic_return_field($1, args);
$$->data.initial = keyword_str($1);
parser_intrinsic_callv( $$, intrinsic_cname($1),
args.size(), args.data() );
| BASECONVERT '(' varg[r1] varg[r2] varg[r3] ')' {
location_set(@1);
- $$ = new_tempnumeric("BASECONVERT");
+ $$ = new_alphanumeric("BASECONVERT");
cbl_unimplemented("BASECONVERT");
if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR;
}
}
| CHAR '(' expr[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(1,"CHAR");
+ $$ = new_alphanumeric("CHAR");
if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR;
}
/* convert formulations:
| FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE, "FORMATTED-DATE");
+ $$ = new_alphanumeric("FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
symbol_temporary_location(r1->field, @r1);
if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR;
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
+ $$ = new_alphanumeric("FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
symbol_temporary_location(r1->field, @r1);
static cbl_refer_t r3(literally_zero);
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] expr[r4] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
+ $$ = new_alphanumeric("FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
symbol_temporary_location(r1->field, @r1);
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-DATETIME");
+ $$ = new_alphanumeric("FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
symbol_temporary_location(r1->field, @r1);
if( ! intrinsic_call_3($$, FORMATTED_TIME,
}
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-TIME");
+ $$ = new_alphanumeric("FORMATTED-TIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
auto r3 = new_reference(new_constant("0"));
symbol_temporary_location(r1->field, @r1);
}
| FORMATTED_CURRENT_DATE '(' DATETIME_FMT[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-CURRENT_DATE");
+ $$ = new_alphanumeric("FORMATTED-CURRENT_DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
symbol_temporary_location(r1->field, @r1);
if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1, @r1) )
}
| lopper_case[func] '(' alpha_val[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity(), "lopper_case[func]");
+ $$ = new_alphanumeric("lopper_case[func]");
if( ! intrinsic_call_1($$, $func, $r1, @r1)) YYERROR;
}
| MODULE_NAME '(' module_type[type] ')'
{
- $$ = new_alphanumeric(sizeof(cbl_name_t), "MODULE-NAME");
+ $$ = new_alphanumeric("MODULE-NAME");
parser_module_name( $$, $type );
}
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
static auto one = new cbl_refer_t( new_constant("1") );
static auto four = new cbl_refer_t( new_constant("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
+ auto r3 = new_reference(new_alphanumeric());
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
intrinsic0: CURRENT_DATE {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "CURRENT-DATE");
+ $$ = new_alphanumeric("CURRENT-DATE");
parser_intrinsic_call_0( $$, "__gg__current_date" );
}
| E {
| PI {
location_set(@1);
- $$ = new_tempnumeric_float("PI");
+ $$ = new_tempnumeric("PI");
parser_intrinsic_call_0( $$, "__gg__pi" );
}
| SECONDS_PAST_MIDNIGHT {
| WHEN_COMPILED {
location_set(@1);
// Returns YYYYMMDDhhmmssss-0500)
- $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "WHEN-COMPILED");
+ $$ = new_alphanumeric("WHEN-COMPILED");
parser_intrinsic_call_0( $$, "__gg__when_compiled" );
}
;
#include <stack>
#include <string>
-#define MAXLENGTH_FORMATTED_DATE (10*4)
-#define MAXLENGTH_FORMATTED_TIME (19*4)
-#define MAXLENGTH_CALENDAR_DATE (21*4)
-#define MAXLENGTH_FORMATTED_DATETIME (30*4)
-
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
return true;
}
-cbl_field_t *
-new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH,
- const cbl_name_t name = nullptr,
- cbl_encoding_t encoding = no_encoding_e );
-
-static inline cbl_field_t *
-new_alphanumeric( const cbl_name_t name, cbl_encoding_t encoding = no_encoding_e ) {
- return new_alphanumeric(MAXIMUM_ALPHA_LENGTH, name, encoding);
-}
-
static inline cbl_refer_t *
new_reference( enum cbl_field_type_t type, const char *initial ) {
return new cbl_refer_t( new_temporary(type, initial) );
static bool ast_divide( arith_t *arith );
static cbl_field_type_t intrinsic_return_type( int token );
+static cbl_field_t *intrinsic_return_field( int token,
+ std::vector<cbl_refer_t> );
template <typename T>
static T* use_any( list<T>& src, T *tgt) {
void dump() const {
int i=0;
for( const auto& arg : elems ) {
- dbgmsg( "%8d) %-10s %-16s %s", i++,
- cbl_ffi_crv_str(arg.crv),
- 3 + cbl_field_type_str(arg.refer.field->type),
- arg.refer.field->pretty_name() );
+ if( arg.refer.field ) {
+ dbgmsg( "%8d) %-10s %-16s %s", i++,
+ cbl_ffi_crv_str(arg.crv),
+ 3 + cbl_field_type_str(arg.refer.field->type),
+ arg.refer.field->pretty_name() );
+ } else {
+ dbgmsg( "%8d) %-10s [omitted]", i++, cbl_ffi_crv_str(arg.crv) );
+ }
}
}
}
}
+template <typename V>
+bool is_among( V value, const std::list<V>& container ) {
+ return std::any_of( container.begin(), container.end(),
+ [value]( const auto& elem ) {
+ return value == elem;
+ } );
+}
+
#pragma GCC diagnostic push
* X Alphanumeric
* n variadic
* We use just A, I, N, or X, choosing the most general for each parameter.
+ *
+ * When FldInvalid is shown as the return type, it indicates that the type
+ * of the function is determined by the type of the first parameter.
+ *
+ * We use FldNumericBin5 for functions of type "Integer", and FldFloat for
+ * functions of type "Numeric",
*/
static const function_descr_t function_descrs[] = {
{ ABS, "ABS",
- "__gg__abs", "N", {}, FldNumericBin5 },
+ "__gg__abs", "N", {}, FldInvalid },
{ ACOS, "ACOS",
- "__gg__acos", "N", {}, FldNumericBin5 },
+ "__gg__acos", "N", {}, FldFloat },
{ ANNUITY, "ANNUITY",
- "__gg__annuity", "NI", {}, FldNumericBin5 },
+ "__gg__annuity", "NI", {}, FldFloat },
{ ASIN, "ASIN",
- "__gg__asin", "N", {}, FldNumericBin5 },
+ "__gg__asin", "N", {}, FldFloat },
{ ATAN, "ATAN",
- "__gg__atan", "N", {}, FldNumericBin5 },
- { BASECONVERT, "BASECONVERT",
- "__gg__baseconvert", "XII", {}, FldNumericBin5 },
+ "__gg__atan", "N", {}, FldFloat },
+ { BASECONVERT, "BASECONVERT",
+ "__gg__baseconvert", "XII", {}, FldAlphanumeric },
{ BIT_OF, "BIT-OF",
"__gg__bit_of", "X", {}, FldAlphanumeric },
{ BIT_TO_CHAR, "BIT-TO-CHAR",
"__gg__bit_to_char", "X", {}, FldAlphanumeric },
// BOOLEAN-OF-INTEGER requires FldBoolean
- { BOOLEAN_OF_INTEGER, "BOOLEAN-OF-INTEGER",
- "__gg__boolean_of_integer", "II", {}, FldNumericBin5 },
+ { BOOLEAN_OF_INTEGER, "BOOLEAN-OF-INTEGER",
+ "__gg__boolean_of_integer", "II", {}, FldNumericBin5 },
{ BYTE_LENGTH, "BYTE-LENGTH",
"__gg__byte_length", "X", {}, FldNumericBin5 },
{ CHAR, "CHAR",
"__gg__char", "I", {}, FldAlphanumeric },
- { CHAR_NATIONAL, "CHAR-NATIONAL",
- "__gg__char_national", "I", {}, FldAlphanumeric },
+ { CHAR_NATIONAL, "CHAR-NATIONAL",
+ "__gg__char_national", "I", {}, FldAlphanumeric },
{ COMBINED_DATETIME, "COMBINED-DATETIME",
- "__gg__combined_datetime", "IN", {}, FldNumericBin5 },
+ "__gg__combined_datetime", "IN", {}, FldFloat },
{ CONCAT, "CONCAT",
"__gg__concat", "n", {}, FldAlphanumeric },
- { CONVERT, "CONVERT",
- "__gg__convert", "XII", {}, FldAlphanumeric },
+ { CONVERT, "CONVERT",
+ "__gg__convert", "XII", {}, FldAlphanumeric },
{ COS, "COS",
- "__gg__cos", "N", {}, FldNumericBin5 },
+ "__gg__cos", "N", {}, FldFloat },
{ CURRENT_DATE, "CURRENT-DATE",
"__gg__current_date", "", {}, FldAlphanumeric },
{ DATE_OF_INTEGER, "DATE-OF-INTEGER",
"__gg__display_of", "UUI", {}, FldAlphanumeric },
{ E, "E",
"__gg_e", "", {}, FldNumericBin5 },
-
{ EXCEPTION_FILE, "EXCEPTION-FILE",
"__gg__func_exception_file", "", {}, FldAlphanumeric },
{ EXCEPTION_FILE_N, "EXCEPTION-FILE-N",
"__gg__func_exception_statement", "", {}, FldAlphanumeric },
{ EXCEPTION_STATUS, "EXCEPTION-STATUS",
"__gg__func_exception_status", "", {}, FldAlphanumeric },
-
{ EXP, "EXP",
- "__gg__exp", "N", {}, FldNumericBin5 },
+ "__gg__exp", "N", {}, FldFloat },
{ EXP10, "EXP10",
- "__gg__exp10", "N", {}, FldNumericBin5 },
+ "__gg__exp10", "N", {}, FldFloat },
{ FACTORIAL, "FACTORIAL",
"__gg__factorial", "I", {}, FldNumericBin5 },
{ FIND_STRING, "FIND-STRING",
{ FORMATTED_DATETIME, "FORMATTED-DATETIME",
"__gg__formatted_datetime", "XINI", {}, FldAlphanumeric },
{ FORMATTED_TIME, "FORMATTED-TIME",
- "__gg__formatted_time", "INI", {}, FldNumericBin5 },
+ "__gg__formatted_time", "INI", {}, FldAlphanumeric },
{ FRACTION_PART, "FRACTION-PART",
- "__gg__fraction_part", "N", {}, FldNumericBin5 },
+ "__gg__fraction_part", "N", {}, FldFloat },
{ HEX_OF, "HEX-OF",
"__gg__hex_of", "X", {}, FldAlphanumeric },
{ HEX_TO_CHAR, "HEX-TO-CHAR",
"__gg__hex_to_char", "X", {}, FldAlphanumeric },
{ HIGHEST_ALGEBRAIC, "HIGHEST-ALGEBRAIC",
- "__gg__highest_algebraic", "N", {}, FldNumericBin5 },
+ "__gg__highest_algebraic", "N", {}, FldInvalid },
{ INTEGER, "INTEGER",
"__gg__integer", "N", {}, FldNumericBin5 },
// requires FldBoolean
- { INTEGER_OF_BOOLEAN, "INTEGER-OF-BOOLEAN",
- "__gg__integer_of_boolean", "B", {}, FldNumericBin5 },
+ { INTEGER_OF_BOOLEAN, "INTEGER-OF-BOOLEAN",
+ "__gg__integer_of_boolean", "B", {}, FldNumericBin5 },
{ INTEGER_OF_DATE, "INTEGER-OF-DATE",
"__gg__integer_of_date", "I", {}, FldNumericBin5 },
{ INTEGER_OF_DAY, "INTEGER-OF-DAY",
"__gg__locale_time", "XX", {}, FldNumericBin5 },
{ LOCALE_TIME_FROM_SECONDS, "LOCALE-TIME-FROM-SECONDS",
"__gg__locale_time_from_seconds", "NX", {}, FldNumericBin5 },
-
{ LOG, "LOG",
- "__gg__log", "N", {}, FldNumericBin5 },
+ "__gg__log", "N", {}, FldFloat },
{ LOG10, "LOG10",
- "__gg__log10", "N", {}, FldNumericBin5 },
+ "__gg__log10", "N", {}, FldFloat },
{ LOWER_CASE, "LOWER-CASE",
"__gg__lower_case", "X", {}, FldAlphanumeric },
{ LOWEST_ALGEBRAIC, "LOWEST-ALGEBRAIC",
- "__gg__lowest_algebraic", "N", {}, FldNumericBin5 },
-
+ "__gg__lowest_algebraic", "N", {}, FldInvalid },
{ MAXX, "MAX",
- "__gg__max", "n", {}, FldAlphanumeric },
+ "__gg__max", "n", {}, FldInvalid },
{ MEAN, "MEAN",
- "__gg__mean", "n", {}, FldNumericBin5 },
+ "__gg__mean", "n", {}, FldFloat },
{ MEDIAN, "MEDIAN",
- "__gg__median", "n", {}, FldNumericBin5 },
+ "__gg__median", "n", {}, FldFloat },
{ MIDRANGE, "MIDRANGE",
- "__gg__midrange", "n", {}, FldNumericBin5 },
+ "__gg__midrange", "n", {}, FldFloat },
{ MINN, "MIN",
- "__gg__min", "n", {}, FldAlphanumeric },
+ "__gg__min", "n", {}, FldInvalid },
{ MOD, "MOD",
"__gg__mod", "IN", {}, FldNumericBin5 },
- { MODULE_NAME, "MODULE-NAME",
- "__gg__module_name", "I", {}, FldAlphanumeric },
+ { MODULE_NAME, "MODULE-NAME",
+ "__gg__module_name", "I", {}, FldAlphanumeric },
{ NATIONAL_OF, "NATIONAL-OF",
"__gg__national_of", "XX", {}, FldAlphanumeric },
{ NUMVAL, "NUMVAL",
- "__gg__numval", "X", {}, FldNumericBin5 },
+ "__gg__numval", "X", {}, FldFloat },
{ NUMVAL_C, "NUMVAL-C",
- "__gg__numval_c", "XXU", {}, FldNumericBin5 },
+ "__gg__numval_c", "XXU", {}, FldFloat },
{ NUMVAL_F, "NUMVAL-F",
- "__gg__numval_f", "X", {}, FldNumericBin5 },
+ "__gg__numval_f", "X", {}, FldFloat },
{ ORD, "ORD",
"__gg__ord", "X", {}, FldNumericBin5 },
{ ORD_MAX, "ORD-MAX",
{ PI, "PI",
"__gg__pi", "", {}, FldNumericBin5 },
{ PRESENT_VALUE, "PRESENT-VALUE",
- "__gg__present_value", "n", {}, FldNumericBin5 },
+ "__gg__present_value", "n", {}, FldFloat },
{ RANDOM, "RANDOM",
- "__gg__random", "I", {}, FldNumericBin5 },
+ "__gg__random", "I", {}, FldFloat },
{ RANGE, "RANGE",
- "__gg__range", "n", {}, FldNumericBin5 },
+ "__gg__range", "n", {}, FldInvalid },
{ REM, "REM",
- "__gg__rem", "NN", {}, FldNumericBin5 },
+ "__gg__rem", "NN", {}, FldFloat },
{ REVERSE, "REVERSE",
"__gg__reverse", "X", {}, FldAlphanumeric },
{ SECONDS_FROM_FORMATTED_TIME, "SECONDS-FROM-FORMATTED-TIME",
- "__gg__seconds_from_formatted_time", "XX", {}, FldAlphanumeric },
+ "__gg__seconds_from_formatted_time", "XX", {}, FldFloat },
{ SECONDS_PAST_MIDNIGHT, "SECONDS_PAST_MIDNIGHT",
- "__gg__seconds_past_midnight", "", {}, FldAlphanumeric },
+ "__gg__seconds_past_midnight", "", {}, FldFloat },
{ SIGN, "SIGN",
"__gg__sign", "N", {}, FldNumericBin5 },
{ SIN, "SIN",
- "__gg__sin", "N", {}, FldNumericBin5 },
- { SMALLEST_ALGEBRAIC, "SMALLEST-ALGEBRAIC",
- "__gg__smallest_algebraic", "N", {}, FldNumericBin5 },
+ "__gg__sin", "N", {}, FldFloat },
+ { SMALLEST_ALGEBRAIC, "SMALLEST-ALGEBRAIC",
+ "__gg__smallest_algebraic", "N", {}, FldInvalid },
{ SQRT, "SQRT",
- "__gg__sqrt", "N", {}, FldNumericBin5 },
- { STANDARD_COMPARE, "STANDARD-COMPARE",
- "__gg__standard_compare", "XXXI", {}, FldAlphanumeric },
+ "__gg__sqrt", "N", {}, FldFloat },
+ { STANDARD_COMPARE, "STANDARD-COMPARE",
+ "__gg__standard_compare", "XXXI", {}, FldAlphanumeric },
{ STANDARD_DEVIATION, "STANDARD-DEVIATION",
- "__gg__standard_deviation", "n", {}, FldNumericBin5 },
- { SUBSTITUTE, "SUBSTITUTE",
- "__gg__substitute", "XXX", {}, FldAlphanumeric },
+ "__gg__standard_deviation", "n", {}, FldFloat },
+ { SUBSTITUTE, "SUBSTITUTE",
+ "__gg__substitute", "XXX", {}, FldAlphanumeric },
{ SUM, "SUM",
- "__gg__sum", "n", {}, FldNumericBin5 },
+ "__gg__sum", "n", {}, FldInvalid },
{ TAN, "TAN",
- "__gg__tan", "N", {}, FldNumericBin5 },
+ "__gg__tan", "N", {}, FldFloat },
{ TEST_DATE_YYYYMMDD, "TEST-DATE-YYYYMMDD",
"__gg__test_date_yyyymmdd", "I", {}, FldNumericBin5 },
{ TEST_DAY_YYYYDDD, "TEST-DAY-YYYYDDD",
{ UWIDTH, "UWIDTH",
"__gg__uwidth", "XI", {}, FldAlphanumeric },
{ VARIANCE, "VARIANCE",
- "__gg__variance", "n", {}, FldNumericBin5 },
+ "__gg__variance", "n", {}, FldFloat },
{ WHEN_COMPILED, "WHEN-COMPILED",
"__gg__when_compiled", "", {}, FldAlphanumeric },
{ YEAR_TO_YYYY, "YEAR-TO-YYYY",
return p == function_descrs_end? FldAlphanumeric : p->ret_type;
}
+static cbl_field_t *
+intrinsic_return_field(int token, std::vector<cbl_refer_t> args)
+ {
+ cbl_field_t *retval;
+
+ cbl_field_type_t func_type = intrinsic_return_type(token);
+ switch(func_type)
+ {
+ case FldAlphanumeric:
+ retval = new_alphanumeric();
+ break;
+ case FldNumericBin5:
+ retval = new_tempnumeric();
+ break;
+ case FldFloat:
+ retval = new_tempnumeric_float();
+ break;
+ case FldInvalid:
+ // This is a flag that a function takes the type of its first input
+ assert( args.size() );
+ switch(args[0].field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ retval = new_alphanumeric();
+ break;
+ case FldNumericBinary:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ case FldPointer:
+ retval = new_tempnumeric();
+ break;
+ case FldFloat:
+ retval = new_tempnumeric_float();
+ break;
+ default:
+ retval = NULL;
+ gcc_unreachable();
+ break;
+ }
+ break;
+ default:
+ retval = NULL;
+ gcc_unreachable();
+ break;
+ }
+
+ return retval;
+ }
+
static const char *
intrinsic_cname( int token ) {
auto p = std::find_if( function_descrs,
}
<INITIAL,procedure_div,cdf_state>{
+ (IS{SPC})?"<" { return '<'; }
+ (IS{SPC})?"<=" { return LE; }
+ (IS{SPC})?"=" { static char eq[] = "=";
+ ydflval.string = yylval.string = eq;
+ return EQ; }
+ (IS{SPC})?"<>" { return NE; }
+ (IS{SPC})?">=" { return GE; }
+ (IS{SPC})?">" { return '>'; }
+
+ {LESS_THAN} { return '<'; }
+ {LESS_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return LE; }
+ (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] {
+ static char eq[] = "EQUAL";
+ ydflval.string = yylval.string = eq;
+ return EQ; }
+ {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; }
+ {GREATER_THAN} { return '>'; }
+
+ {ISNT}{OSPC}">=" { verify_ws(yytext[yyleng - 3]); return '<'; }
+ {ISNT}{OSPC}">" { verify_ws(yytext[yyleng - 2]); return LE; }
+ {ISNT}{OSPC}"=" { verify_ws(yytext[yyleng - 2]); return NE; }
+ {ISNT}{OSPC}"<" { verify_ws(yytext[yyleng - 2]); return GE; }
+ {ISNT}{OSPC}"<=" { verify_ws(yytext[yyleng - 3]); return '>'; }
+
+ {ISNT}{SPC}GREATER{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; }
+ {ISNT}{SPC}GREATER{SPC}(THAN)? { return LE; }
+ {ISNT}{SPC}EQUALS?{SPC}(TO)? { return NE; }
+ {ISNT}{SPC}LESS{SPC}(THAN)? { return GE; }
+ {ISNT}{SPC}LESS{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; }
+
+ [*]{2} { return POW; }
+
+ /*
+ * "A boolean operator specifies the type of boolean operation to be performed
+ * on one or two operands, for a unary operator or binary operator,
+ * respectively."
+ * Binary boolean operators
+ * B-AND B-OR B-XOR
+ * Unary boolean operator
+ * B-NOT
+ * Boolean shift operators
+ * B-SHIFT-L B-SHIFT-LC B-SHIFT-R B-SHIFT-RC
+ */
+ /****
+B-AND
+B-OR
+B-XOR
+B-NOT
+B-SHIFT-L
+B-SHIFT-LC
+B-SHIFT-R
+B-SHIFT-RC
+ ****/
/* unused Context Words */
ARITHMETIC { return ARITHMETIC; }
DEPENDING { return DEPENDING; }
DESCENDING { return DESCENDING; }
DISPLAY { return DISPLAY; }
+ EBCDIC { return EBCDIC; }
EJECT{DOTEOL}? {
dialect_ok(yylloc, IbmEjectE, "EJECT");
auto len = yyleng - 1;
LEADING { return LEADING; }
LEFT { return LEFT; }
MODE { return MODE; }
+ NATIVE { return NATIVE; }
NO { return NO; }
OCCURS/{SPC}{NAME} { return OCCURS; }
OCCURS { yy_push_state(integer_count); return OCCURS; }
SIGN { return SIGN; }
SIZE { return SIZE; }
STANDARD { return STANDARD; }
+ STANDARD{SPC}ALPHABET { return STANDARD_ALPHABET; }
STRONG { return STRONG; }
SYNC(HRONIZED)? { return SYNCHRONIZED; }
TIMES { return TIMES; }
}
}
-<cdf_state,procedure_div>{
- (IS{SPC})?"<" { return '<'; }
- (IS{SPC})?"<=" { return LE; }
- (IS{SPC})?"=" { static char eq[] = "=";
- ydflval.string = yylval.string = eq;
- return EQ; }
- (IS{SPC})?"<>" { return NE; }
- (IS{SPC})?">=" { return GE; }
- (IS{SPC})?">" { return '>'; }
-
- {LESS_THAN} { return '<'; }
- {LESS_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return LE; }
- (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] {
- static char eq[] = "EQUAL";
- ydflval.string = yylval.string = eq;
- return EQ; }
- {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; }
- {GREATER_THAN} { return '>'; }
-
- {ISNT}{OSPC}">=" { verify_ws(yytext[yyleng - 3]); return '<'; }
- {ISNT}{OSPC}">" { verify_ws(yytext[yyleng - 2]); return LE; }
- {ISNT}{OSPC}"=" { verify_ws(yytext[yyleng - 2]); return NE; }
- {ISNT}{OSPC}"<" { verify_ws(yytext[yyleng - 2]); return GE; }
- {ISNT}{OSPC}"<=" { verify_ws(yytext[yyleng - 3]); return '>'; }
-
- {ISNT}{SPC}GREATER{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; }
- {ISNT}{SPC}GREATER{SPC}(THAN)? { return LE; }
- {ISNT}{SPC}EQUALS?{SPC}(TO)? { return NE; }
- {ISNT}{SPC}LESS{SPC}(THAN)? { return GE; }
- {ISNT}{SPC}LESS{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; }
-
- [*]{2} { return POW; }
-
- /*
- * "A boolean operator specifies the type of boolean operation to be performed
- * on one or two operands, for a unary operator or binary operator,
- * respectively."
- * Binary boolean operators
- * B-AND B-OR B-XOR
- * Unary boolean operator
- * B-NOT
- * Boolean shift operators
- * B-SHIFT-L B-SHIFT-LC B-SHIFT-R B-SHIFT-RC
- */
-
-B-AND
-B-OR
-B-XOR
-B-NOT
-B-SHIFT-L
-B-SHIFT-LC
-B-SHIFT-R
-B-SHIFT-RC
-
-}
-
<procedure_div>{
(ID|IDENTIFICATION|ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION {
myless(0); BEGIN(INITIAL); }
{ISNT}{SPC}NEGATIVE/[[:space:]] { yylval.number = NOT; return NEGATIVE; }
{ISNT}{SPC}ZERO/[[:space:]] { yylval.number = NOT; return ZERO; }
+ {ISNT}{SPC}/OMITTED { return NOT; }
+
[(:)] { return *yytext; }
[(]/[^(:)""'']*[:][^)]*[)] { return LPAREN; /* parentheses around a colon */ }
+ [(][^:""''\n]*[:][^)]*[)] { // does not match foo(bar)\n: :-(
+ int tok = is_refmod(yytext, yytext + yyleng)?
+ int(LPAREN) : '(';
+ myless(1);
+ return tok;
+ }
FILLER { return FILLER_kw; }
INVALID { yylval.number = INVALID; return INVALID; }
{POP_FILE} {
yy_set_bol(true);
+ yylineno = input_file_status.pending().lineno;
input_file_status.leave();
- yylineno = cobol_lineno();
+ dbgmsg("banged yylineno to %d", yylineno);
}
{LINE_DIRECTIVE} {
}
};
-static class input_file_status_t {
+/*
+ * The lexer knows the immediate status of the input file and its line number
+ * from the PUSH, POP, and LINE directives. It saves yylineno whenever it
+ * encounters a PUSH, and updates it for a POP.
+ *
+ * The line number trickles into the parser by way of location. Only the
+ * parser knows what token it is parsing. As for the filename, the lexer
+ * queues enter/leave notices for the parser.
+ *
+ * Whenever the parser fetches a token, it gets the current line number from
+ * yylineno, and the current filename by depleting the notification queue, if
+ * any, and using the last one.
+ */
+class input_file_status_t {
+ public:
+ struct input_pos_t { int lineno; const char *filename; };
+ private:
std::queue <enter_leave_t> inputs;
+ std::stack<input_pos_t> positions;
public:
void enter(const char *filename) {
inputs.push( enter_leave_t(parser_enter_file, filename) );
+ positions.push( input_pos_t{ yylineno, filename } );
}
void leave() {
inputs.push( enter_leave_t(parser_leave_file) );
+ positions.pop();
}
void notify() {
while( ! inputs.empty() ) {
inputs.pop();
}
}
-} input_file_status;
+ input_pos_t pending() const { assert( ! positions.empty() ); return positions.top(); }
+};
+
+static input_file_status_t input_file_status;
void input_file_status_notify() { input_file_status.notify(); }
}
static void
-verify_ws( const YYLTYPE& loc, const char [] /* input[] */, char ch ) {
+verify_ws( char ch ) {
if( ! fisspace(ch) ) {
- dialect_ok(loc, LexSeparatorE, "missing separator space");
+ dialect_ok(yylloc, LexSeparatorE, "missing separator space");
}
}
-#define verify_ws(C) verify_ws(yylloc, yytext, C)
int
binary_integer_usage_of( const char name[] ) {
return output;
}
-
-
-
-
-
+/*
+ * Loosely parse what might be a refmod expression. This is used to decide
+ * whether to indicate a refmod to the parser with an LPAREN token, or not,
+ * with a '(' token. The input is known to have a first line that begins with
+ * '('., includes ':', and ends with ')'.
+ */
+static bool
+is_refmod( const char input[], const char enput[] ) {
+ if( input == enput ) return false;
+
+ switch(*input) {
+ case '(':
+ input = std::find( ++input, enput, ')');
+ if( input == enput ) return false;
+ return is_refmod(++input, enput);
+ case ':':
+ return is_refmod(++input, enput);
+ case ')':
+ if( ++input == enput ) return true;
+ return is_refmod(input, enput);
+ default:
+ if( ISSPACE(*input) ) {
+ input = std::find_if( ++input, enput,
+ []( char ch ) {
+ return ! ISSPACE(ch);
+ } );
+ return is_refmod(input, enput);
+ }
+ break;
+ }
+ input = std::find_if( input, enput,
+ [start = *input]( char ch ) {
+ bool yes = false;
+ if( ISDIGIT(start) ) {
+ switch(ch) {
+ case '+': case '-': case '*': case '/':
+ yes = true; break;
+ case '.': case ',':
+ yes = true; break;
+ default:
+ yes = ISDIGIT(ch);
+ break;
+ }
+ } else {
+ assert(ISALNUM(start));
+ switch(ch) {
+ case '-':
+ yes = true; break;
+ default:
+ yes = ISALNUM(ch);
+ break;
+ }
+ }
+ return !yes;
+ } );
+ return is_refmod(input, enput);
+}
return 0;
}
}
- // Better to report an error than to fail mysteriously with "0 errors".
+ /*
+ * The parser sets an incomplete field with 0 capacity to FldInvalid. If
+ * the field proves to be a group symbol_field_add() sets it to FldGroup
+ * and its size is calculated above. If that doesn't happen, it gets
+ * flagged here.
+ */
if( yydebug || parse_error_count() == 0 ) {
if( field->type == FldInvalid ) {
ERROR_FIELD(field, "line %d: %s %s requires PICTURE",
error_msg(loc, "ALSO value %zu is unknown", ch);
}
-using std::deque;
-static deque<cbl_field_t*> stack;
+static symbol_temporaries_t program_temporaries;
+
+/*
+ * Supply a reference to the current list of temporaries for use by codegen to free
+ * the memory if it decides to return to the caller.
+ */
+symbol_temporaries_t&
+symbol_temporaries() {
+ return program_temporaries;
+}
+
+symbol_temporaries_t
+symbol_temporary_alphanumerics() {
+ symbol_temporaries_t output;
+ std::copy_if( program_temporaries.begin(),
+ program_temporaries.end(),
+ std::back_inserter(output),
+ []( auto f ) {
+ switch(f->type) {
+ case FldAlphaEdited:
+ case FldAlphanumeric:
+ return f->has_attr(intermediate_e);
+ case FldFloat:
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldPacked:
+ default:
+ break;
+ }
+ return false;
+ } );
+ for( cbl_field_t *f : output ) {
+ auto p = std::find( program_temporaries.begin(),
+ program_temporaries.end(),
+ f );
+ program_temporaries.erase(p);
+ }
+ return output;
+}
/*
* Allocate a temporary field. Assign the type and name, if supplied. Caller
extern int yylineno;
static const struct cbl_field_t empty_alpha = {
FldAlphanumeric, intermediate_e,
- {MAXIMUM_ALPHA_LENGTH,
- MAXIMUM_ALPHA_LENGTH, 0, 0, NULL} };
+ {0,
+ 0, 0, 0, NULL} };
static const struct cbl_field_t empty_float = {
FldFloat, intermediate_e,
{16, 16, 32, 0, NULL} };
f->codeset.set();
+ program_temporaries.push_back(f);
+
return f;
}
}
cbl_field_t *
-new_alphanumeric( size_t capacity, const cbl_name_t name, cbl_encoding_t encoding ) {
+new_alphanumeric( const cbl_name_t name, cbl_encoding_t encoding ) {
cbl_field_t * field = new_temporary_impl(FldAlphanumeric, name);
- field->set_capacity( capacity );
if( encoding != no_encoding_e ) {
field->codeset.set(encoding);
}
}
return "???";
-};
+}
// Dialects may be combined.
extern unsigned int cbl_dialects;
SymLocale,
};
-// The ISO specification says alphanumeric literals have a maximum length of
-// 8,191 characters. It seems to be silent on the length of alphanumeric data
-// items. Our implementation requires a maximum length, so we chose to make it
-// the same.
-#define MAXIMUM_ALPHA_LENGTH 8192
+// From Enterprise COBOL for z/OS 6.4 Language Reference, Appendix B.
+// ISO specifies no limit in 13.18.40.3 Syntax rules.
+// CobolCraft sometimes needs 2,100,000 or about 2 MB.
+#ifdef COBOL_MAXIMUM_ALPHA_LENGTH
+# define MAXIMUM_ALPHA_LENGTH size_t(COBOL_MAXIMUM_ALPHA_LENGTH)
+#else
+# define IBM_MAXIMUM_ALPHA_LENGTH (size_t(1) << 31)
+# define MAXIMUM_ALPHA_LENGTH IBM_MAXIMUM_ALPHA_LENGTH
+#endif
class cbl_field_data_t {
uint32_t nbyte; // allocated space
const cbl_field_t * cbl_figconst_field_of( const char *value );
+typedef std::list<cbl_field_t*> symbol_temporaries_t;
+
+symbol_temporaries_t& symbol_temporaries();
+symbol_temporaries_t symbol_temporary_alphanumerics();
+
// Necessary forward referencea
struct cbl_label_t;
struct cbl_refer_t;
char cname[48];
char types[8];
std::vector<function_descr_arg_t> linkage_fields;
- cbl_field_type_t ret_type;
-
+ cbl_field_type_t ret_type; // When the ret_type is FldInvalid, that
+ // indicates the function takes on the type of
+ // the first argument.
static function_descr_t init( const char name[] ) {
function_descr_t descr = {};
if( -1 == snprintf( descr.name, sizeof(descr.name), "%s", name ) ) {
bool validate_numeric_edited(cbl_field_t *field);
+cbl_field_t *new_alphanumeric(const cbl_name_t name=nullptr,
+ cbl_encoding_t encoding=no_encoding_e );
+
#endif
{
template <typename T>
class cdf_stack_t : private std::stack<T> { // cppcheck-suppress noConstructor
- T default_value;
+ T current_value;
const T& top() const { return std::stack<T>::top(); }
bool empty() const { return std::stack<T>::empty(); }
public:
void value( const T& value ) {
- T& output( empty()? default_value : std::stack<T>::top() ); // cppcheck-suppress constVariableReference
- output = value;
- dbgmsg("cdf_directives_t::%s: %s", __func__, str(output).c_str());
+ current_value = value;
+ dbgmsg("cdf_directives_t::%s: %s", __func__, str(current_value).c_str());
}
T& value() {
- return empty()? default_value : std::stack<T>::top();
+ return current_value;
}
void push() {
std::stack<T>::push(value());
error_msg(YYLTYPE(), "CDF stack empty"); // cppcheck-suppress syntaxError
return;
}
- default_value = top();
+ current_value = top();
std::stack<T>::pop();
- dbgmsg("cdf_directives_t::%s: %s", __func__, str(default_value).c_str());
+ dbgmsg("cdf_directives_t::%s: %s", __func__, str(current_value).c_str());
}
protected:
static std::string str(cbl_call_convention_t arg) {
void
cobol_set_indicator_column( int column ) {
cdf_directives.source_format.value().indicator_column_set(column);
+ dbgmsg("%s: format now %s", __func__,
+ cdf_directives.source_format.value().description());
}
source_format_t& cdf_source_format() {
return cdf_directives.source_format.value();
void cdf_push_current_tokens() { cdf_directives.cobol_words.push(); }
void cdf_push_dictionary() { cdf_directives.dictionary.push(); }
void cdf_push_enabled_exceptions() { cdf_directives.enabled_exceptions.push(); }
-void cdf_push_source_format() { cdf_directives.source_format.push(); }
+void cdf_push_source_format() {
+ cdf_directives.source_format.push();
+ dbgmsg("%s: format still %s", __func__,
+ cdf_directives.source_format.value().description());
+}
void cdf_pop() { cdf_directives.pop(); }
void cdf_pop_call_convention() { cdf_directives.call_convention.pop(); }
void cdf_pop_current_tokens() { cdf_directives.cobol_words.pop(); }
void cdf_pop_dictionary() { cdf_directives.dictionary.pop(); }
void cdf_pop_enabled_exceptions() { cdf_directives.enabled_exceptions.pop(); }
-void cdf_pop_source_format() { cdf_directives.source_format.pop(); }
+void cdf_pop_source_format() {
+ cdf_directives.source_format.pop();
+ dbgmsg("%s: format now %s", __func__,
+ cdf_directives.source_format.value().description());
+}
/*
* Construct a cbl_field_t from a CDF literal, to be installed in the symbol table.
if( is_filler(cbl_field_of(elem)) ) return;
- // dbgmsg("%s: asked about %s of %s (" HOST_SIZE_T_PRINT_UNSIGNED " away)", __func__,
- // cbl_field_of(elem)->name,
- // cbl_field_of(group)->name, (fmt_size_t)(elem - group));
-
for( const symbol_elem_t *e=elem; e && group < e; e = symbol_parent(e) ) {
names.push_front( cbl_field_of(e)->name );
}
}
-extern int yylineno;
class find_corresponding {
public:
enum type_t { arith_op, move_op };
linemap_add(line_table, LC_ENTER, sysp, name, 1);
input_filename_vestige = name;
bool pushed = input_filenames.push( input_file_t(name, inode, 1) );
+ dbgmsg("%s: %s %s", __func__, pushed? "pushed" : "set to", name);
return pushed;
}
if( input_filenames.empty() ) return NULL;
auto& input( input_filenames.top() );
input.lineno = lineno;
+ dbgmsg("%s:%d: saved %s, line %d", __func__, __LINE__,
+ input.name, input.lineno);
return input.name;
}
if( input_filenames.empty() ) return 0;
size_t n = input_filenames.size() < 2? 0 : 1;
const auto& input( input_filenames.peek(n) );
+ dbgmsg("%s:%d: fetch %s, line %d", __func__, __LINE__,
+ input.name, input.lineno);
return input.lineno;
}
old_filenames[top.name] = top.inode;
input_filename_vestige = top.name;
- input_filenames.pop();
- if( input_filenames.empty() ) return;
+ dbgmsg("%s: LEAVE %s", __func__, top.name);
- const auto& input = input_filenames.top();
+ input_filenames.pop();
linemap_add(line_table, LC_LEAVE, sysp, NULL, 0);
}
string_to_dest(cblc_field_t *dest, const char *psz)
{
charmap_t *charmap = __gg__get_charmap(dest->encoding);
+
+ __gg__adjust_dest_size(dest, charmap->strlen(psz));
+
size_t dest_length = dest->capacity;
size_t source_length = charmap->strlen(psz);
size_t length = std::min(dest_length, source_length);
int converted_char = 0;
memcpy(&converted_char, converted, charmap_dest->stride());
// Space fill the dest:
+
+ __gg__adjust_dest_size(dest, charmap_dest->stride());
charmap_dest-> memset(dest->data,
charmap_dest->mapped_character(ascii_space),
dest->capacity);
retval,
strlen(retval),
&bytes_converted);
- __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
__gg__adjust_dest_size(dest, bytes_converted);
+ __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
free(converted);
}
cbl_char_t format_Z = charmap_from->mapped_character(ascii_Z);
cbl_char_t format_z = charmap_from->mapped_character(ascii_z);
+ // Establish the formatting string:
+ const char *format = PTRCAST(char, (input->data+input_offset));
+ const char *format_end = format + input_size;
+
+ __gg__adjust_dest_size(dest, format_end-format);
+
// Establish the destination, and set it to spaces
char *d = PTRCAST(char, dest->data);
const char *dend = d + dest->capacity;
charmap_to->memset(d, dest_space, dest->capacity);
- // Establish the formatting string:
- const char *format = PTRCAST(char, (input->data+input_offset));
- const char *format_end = format + input_size;
-
bool is_zulu = false;
const char *p = format;
while( p < format_end )
charmap_t *charmap_to = __gg__get_charmap(to);
charmap_t *charmap_from = __gg__get_charmap(from);
+ // Establish the formatting string:
+ char *format = PTRCAST(char, (arg1->data+arg1_offset));
+ const char *format_end = format + arg1_size;
+
+ __gg__adjust_dest_size(dest, format_end-format);
+
cbl_char_t dest_space = charmap_to->mapped_character(ascii_space);
// Establish the destination, and set it to spaces
const char *dend = d + dest->capacity;
charmap_to->memset(d, dest_space, dest->capacity);
- // Establish the formatting string:
- char *format = PTRCAST(char, (arg1->data+arg1_offset));
- const char *format_end = format + arg1_size;
struct cobol_tm ctm = {};
else
{
ftime_replace(d, dend, format, format_end, charmap_from, achftime);
- __gg__adjust_dest_size(dest, format_end-format);
}
}
charmap_t *charmap_from = __gg__get_charmap(from);
charmap_t *charmap_to = __gg__get_charmap(to);
- // Establish the destination, and set it to spaces
- char *d = PTRCAST(char, (dest->data));
- const char *dend = d + dest->capacity;
- memset(d, charmap_from->mapped_character(ascii_space), dest->capacity);
-
// Establish the formatting string:
char *format = PTRCAST(char, (par1->data+par1_o));
char *format_end = format + par1_s;
trim_trailing_spaces(format, format_end, charmap_from->mapped_character(ascii_space));
bool is_zulu = is_zulu_format(format, format_end, charmap_from);
+ __gg__adjust_dest_size(dest, format_end-format);
+
+ // Establish the destination, and set it to spaces
+ char *d = PTRCAST(char, (dest->data));
+ const char *dend = d + dest->capacity;
+ memset(d, charmap_from->mapped_character(ascii_space), dest->capacity);
+
+
struct cobol_tm ctm = {};
populate_ctm_from_date(ctm, par2, par2_o, par2_s);
else
{
ftime_replace(d, dend, format, format_end, charmap_from, achftime);
- __gg__adjust_dest_size(dest, format_end-format);
}
}
int dest_space = charmap_to->mapped_character(ascii_space);
- // Establish the destination, and set it to spaces
- char *d = PTRCAST(char, dest->data);
- const char *dend = d + dest->capacity;
- charmap_to->memset(d, dest_space, dest->capacity);
-
// Establish the formatting string:
char *format = PTRCAST(char, (par1->data+par1_o));
char *format_end = format + par1_s;
charmap_from->mapped_character(ascii_space));
bool is_zulu = is_zulu_format(format, format_end, charmap_from);
+ __gg__adjust_dest_size(dest, format_end-format);
+
+ // Establish the destination, and set it to spaces
+ char *d = PTRCAST(char, dest->data);
+ const char *dend = d + dest->capacity;
+ charmap_to->memset(d, dest_space, dest->capacity);
+
+
struct cobol_tm ctm = {};
populate_ctm_from_time( ctm,
par2,
}
else
{
- ftime_replace(d, dend, format, format_end, charmap_from, achftime);
__gg__adjust_dest_size(dest, format_end-format);
+ ftime_replace(d, dend, format, format_end, charmap_from, achftime);
}
}
free(duped);
char *duped2 = static_cast<char *>(__gg__memdup(converted, converted_bytes));
+ __gg__adjust_dest_size(dest, converted_bytes);
__gg__field_from_string(dest,
0,
dest->capacity,
duped2,
converted_bytes);
free(duped2);
- __gg__adjust_dest_size(dest, converted_bytes);
}
__gg__adjust_dest_size(dest, ncount);
memmove(dest->data, left, ncount);
+ free(copy);
}
#if HAVE_INITSTATE_R && HAVE_SRANDOM_R && HAVE_RANDOM_R
charmap_t *charmap = __gg__get_charmap(to);
size_t stride = charmap->stride();
- size_t dest_length = dest->capacity;
// Convert the input to the destination encoding
size_t bytes_converted;
// copy over characters from the end of the copy to the beginning of dest:
size_t i_from = bytes_converted - stride;
size_t i_to = 0;
+ __gg__adjust_dest_size(dest, bytes_converted);
+ size_t dest_length = dest->capacity;
while( i_from < bytes_converted && i_to < dest_length )
{
cbl_char_t ch = charmap->getch(converted, i_from);
i_from -= stride;
i_to += stride;
}
- __gg__adjust_dest_size(dest, i_to);
}
extern "C"
}
else
{
- // Default locale
+ // This code just isn't right. ISO says they can be of different classes;
+ // we are assuming they are the same class. We need to detect if one is
+ // national and the other alphanumeric/display, and convert the
+ // alphanumeric string to national before comparing.
achretval[0] = '=';
size_t length = std::min(arg1_s, arg2_s);
for(size_t i=0; i<length; i++ )
}
}
- __gg__convert_encoding(achretval,
- DEFAULT_SOURCE_ENCODING,
- dest->encoding);
- memcpy(dest->data, achretval, strlen(achretval));
- __gg__adjust_dest_size(dest, strlen(achretval));
+ size_t nbytes;
+ const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
+ dest->encoding,
+ achretval,
+ strlen(achretval),
+ &nbytes);
+ __gg__adjust_dest_size(dest, nbytes);
+ memcpy(dest->data, converted, nbytes);
}
extern "C"
ach,
strlen(ach),
&bytes_converted);
- __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
__gg__adjust_dest_size(dest, bytes_converted);
+ __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
free(converted);
}
ach,
strlen(ach),
&bytes_converted);
- __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
__gg__adjust_dest_size(dest, bytes_converted);
+ __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
free(converted);
}
ach,
strlen(ach),
&bytes_converted);
- __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
__gg__adjust_dest_size(dest, bytes_converted);
+ __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted);
free(converted);
}
index += source_rdigits;
}
(*dest)[index++] = NULLCH ;
+ if( var->attr & intermediate_e )
+ {
+ if( value == 0 )
+ {
+ strcpy(*dest, "0");
+ }
+ else
+ {
+ // An intermediate is a rubber-band variable. It has no formal format.
+ // So, to make it cleaner for display purposes, let's clear off leading
+ // '+' characters and trailing zeroes.
+ if( **dest == ascii_plus )
+ {
+ memmove(*dest, (*dest)+1, strlen(*dest));
+ }
+ if( strchr(*dest, charmap->decimal_point()) )
+ {
+ // There is a decimal point. Strip off trailing zeros:
+ char *p = *dest + strlen(*dest)-1;
+ while( *p == ascii_zero )
+ {
+ *p-- = '\0';
+ }
+ // And if we are left with just a decimal point, strip that off, too.
+ while( *p == charmap->decimal_point() )
+ {
+ *p = '\0';
+ }
+ }
+ }
+ }
}
break;
char defaultbyte = flag_bits & DEFAULT_BYTE_MASK;
unsigned int nsubscripts = (flag_bits & NSUBSCRIPT_MASK) >> NSUBSCRIPT_SHIFT;
- if( var->data == NULL
- && var->attr & (intermediate_e)
- && var->type != FldLiteralA
- && var->type != FldLiteralN )
- {
- var->data = static_cast<unsigned char *>(malloc(var->capacity));
- }
-
// Set the "initialized" bit, which is tested in parser_symbol_add to make
// sure this code gets executed only once.
//fprintf(stderr, "__gg__initialize_variable %s setting initialize_e\n", var->name);
ach,
strlen(ach),
&nbytes );
- __gg__field_from_string(dest, offset, length, converted, nbytes);
__gg__adjust_dest_size(dest, nbytes);
+ __gg__field_from_string(dest, offset, length, converted, nbytes);
free(converted);
}
stashed_argv[N],
strlen(stashed_argv[N]),
&nbytes );
- __gg__field_from_string(dest, dest_offset, dest_length, converted, nbytes);
__gg__adjust_dest_size(dest, nbytes);
+ __gg__field_from_string(dest, dest_offset, dest_length, converted, nbytes);
free(converted);
retcode = 0; // Okay
}
retval,
strlen(retval),
&nbytes );
- __gg__field_from_string(field, offset, flength, converted, nbytes);
__gg__adjust_dest_size(field, nbytes);
+ __gg__field_from_string(field, offset, flength, converted, nbytes);
free(converted);
retcode = 0; // Okay
}
void
__gg__adjust_dest_size(cblc_field_t *dest, size_t ncount)
{
- if( dest->attr & (intermediate_e) )
+ if( dest->attr & intermediate_e )
{
- if( dest->allocated < ncount )
+ // Make sure at least one byte is allocated; some routines get upset when
+ // dest->data is NULL even when dest->capacity is zero.
+ size_t alloc_size = std::max(1UL, ncount);
+ if( dest->allocated < alloc_size )
{
- fprintf(stderr, "libgcobol.cc:__gg__adjust_dest_size(): "
- "Adjusting %s size upward is not possible.\n",
- dest->name);
- abort();
-// dest->allocated = ncount;
-// dest->data = (unsigned char *)realloc(dest->data, ncount);
+ dest->allocated = alloc_size;
+ free(dest->data);
+ dest->data = static_cast<unsigned char *>(malloc(alloc_size));
}
dest->capacity = ncount;
}
PTRCAST(char, field->data),
field->capacity,
&nbytes);
+ __gg__adjust_dest_size(field, nbytes);
size_t tocopy = std::min(nbytes, field->allocated);
field->capacity = tocopy;
memcpy(field->data, converted, tocopy);
}
-
extern "C"
void
__gg__func_exception_location(cblc_field_t *dest)
break;
}
- __gg__adjust_dest_size(dest, strlen(result));
+ __gg__adjust_dest_size(dest, strlen(result)+1);
memcpy(dest->data, result, strlen(result)+1);
__gg__adjust_encoding(dest);
}
{
// 'string' has to be in the 'field' encoding. Use this when the input
// might, or might not, be nul-terminated, and you don't want a
- // nul-terminator in the data of the target field.
+ // nul-terminator in the data of the target field. For intermediates, the
+ // string must be nul-terminated
charmap_t *charmap = __gg__get_charmap(field->encoding);
+ if( field->attr & intermediate_e )
+ {
+ field_size = SSIZE_MAX;
+ }
size_t nbytes = charmap->strlen(string, field_size);
+ if( field->attr & intermediate_e )
+ {
+ __gg__adjust_dest_size(field, nbytes);
+ field_size = nbytes;
+ }
__gg__field_from_string(field, field_offset, field_size, string, nbytes);
}
size_t field_size,
const char *string)
{
- // 'string' has to be in the 'field' encoding. Use this when the input
- // might, or might not, be nul-terminated, and you *do* want a
- // nul-terminator in the data of the target field if there was one in the
- // input.
-
- // One typical use is processing returned values from external C-style
- // functions, which often return nul-terminated strings.
+ // 'string' has to be in the 'field' encoding. If the target is intermediate,
+ // It has to be nul-terminated in the field's encoding.
charmap_t *charmap = __gg__get_charmap(field->encoding);
+
+ if( field->attr & intermediate_e )
+ {
+ field_size = SSIZE_MAX;
+ }
size_t nbytes = charmap->strlen(string, field_size);
+ if( field->attr & intermediate_e )
+ {
+ __gg__adjust_dest_size(field, nbytes);
+ field_size = nbytes;
+ }
__gg__field_from_string(field,
field_offset,
field_size,
// destination encoding:
size_t i = 0;
size_t d = 0;
+ __gg__adjust_dest_size(dest, 2*nbytes);
while(i < nbytes && d < dest->capacity )
{
cbl_char_t byte = charmap_tgt->getch(converted, &i);
charmap_dest->putch(charmap_dest->mapped_character(lo), dest->data, &d);
}
free(converted);
- __gg__adjust_dest_size(dest, d);
}
else if( dest_format == convert_byte_e )
{
&nbytes);
size_t i = 0;
size_t d = 0;
+ __gg__adjust_dest_size(dest, 4*nbytes);
while(i < nbytes && d < dest->capacity )
{
// Each character is part of a string of hexadecimal digits. So, the
}
}
free(converted);
- __gg__adjust_dest_size(dest, d);
}
else
{
input_o,
input_s,
&nbytes);
+ __gg__adjust_dest_size(dest, nbytes);
size_t len = std::min(nbytes, dest->capacity);
memcpy(dest->data, converted, len);
free(converted);
- __gg__adjust_dest_size(dest, len);
}
}
extern "C" {
-off_t
+off_t
posix_lseek(int fd, off_t offset, int whence) {
static const std::map<int, int> whences {
{ 2, SEEK_SET },
{ 4, SEEK_CUR },
{ 8, SEEK_END },
- };
+ };
- /*
- * Map valid input whence value onto C standard library value.
- * Invalid values are passed through and rejected by lseek(2) per its documentation.
+ /*
+ * Map valid input whence value onto C standard library value.
+ * Invalid values are passed through and rejected by lseek(2) per its documentation.
* (The caller always needs to check for errors anyway.)
*/
auto p = whences.find(whence);
- if( p != whences.end() ) whence = p.second;
+ if( p != whences.end() ) whence = p->second;
return lseek(fd, offset, whence);
}
#include "stat.h"
int
-posix_opent(const char *pathname, int cbl_flags, int cbl_mode) {
+posix_open(const char *pathname, int cbl_flags, int cbl_mode) {
static const std::map<int, int> flag_bits {
{ cbl::PSX_O_RDONLY, O_RDONLY },
{ cbl::PSX_O_WRONLY, O_WRONLY },
- { cbl::PSX_O_RDWR, O_RDWR },
+ { cbl::PSX_O_RDWR, O_RDWR },
{ cbl::PSX_O_CREAT, O_CREAT },
- { cbl::PSX_O_EXCL, O_EXCL },
- { cbl::PSX_O_NOCTTY, O_NOCTTY },
+ { cbl::PSX_O_EXCL, O_EXCL },
+ { cbl::PSX_O_NOCTTY, O_NOCTTY },
{ cbl::PSX_O_TRUNC, O_TRUNC },
- { cbl::PSX_O_APPEND, O_APPEND },
+ { cbl::PSX_O_APPEND, O_APPEND },
{ cbl::PSX_O_NONBLOCK, O_NONBLOCK },
{ cbl::PSX_O_DSYNC, O_DSYNC },
- { cbl::PSX_O_DIRECT, O_DIRECT },
- { cbl::PSX_O_LARGEFILE, O_LARGEFILE },
- { cbl::PSX_O_DIRECTORY, O_DIRECTORY },
- { cbl::PSX_O_NOFOLLOW, O_NOFOLLOW },
- { cbl::PSX_O_NOATIME, O_NOATIME },
- { cbl::PSX_O_CLOEXEC, O_CLOEXEC },
- { cbl::PSX_O_SYNC, O_SYNC },
- { cbl::PSX_O_PATH, O_PATH },
- { cbl::PSX_O_TMPFILE, O_TMPFILE },
- };
+ { cbl::PSX_O_DIRECT, O_DIRECT },
+ { cbl::PSX_O_LARGEFILE, O_LARGEFILE },
+ { cbl::PSX_O_DIRECTORY, O_DIRECTORY },
+ { cbl::PSX_O_NOFOLLOW, O_NOFOLLOW },
+ { cbl::PSX_O_NOATIME, O_NOATIME },
+ { cbl::PSX_O_CLOEXEC, O_CLOEXEC },
+ { cbl::PSX_O_SYNC, O_SYNC },
+ { cbl::PSX_O_PATH, O_PATH },
+ { cbl::PSX_O_TMPFILE, O_TMPFILE },
+ };
static const std::map<int, int> mode_bits {
- { cbl::PSX_S_IXOTH, S_IXOTH },
- { cbl::PSX_S_IWOTH, S_IWOTH },
- { cbl::PSX_S_IROTH, S_IROTH },
- { cbl::PSX_S_IRWXO, S_IRWXO },
- { cbl::PSX_S_IXGRP, S_IXGRP },
- { cbl::PSX_S_IWGRP, S_IWGRP },
- { cbl::PSX_S_IRGRP, S_IRGRP },
- { cbl::PSX_S_IRWXG, S_IRWXG },
- { cbl::PSX_S_IXUSR, S_IXUSR },
- { cbl::PSX_S_IWUSR, S_IWUSR },
- { cbl::PSX_S_IRUSR, S_IRUSR },
- { cbl::PSX_S_IRWXU, S_IRWXU },
- { cbl::PSX_S_ISVTX, S_ISVTX },
- { cbl::PSX_S_ISGID, S_ISGID },
- { cbl::PSX_S_ISUID, S_ISUID },
+ { cbl::PSX_S_IXOTH, S_IXOTH },
+ { cbl::PSX_S_IWOTH, S_IWOTH },
+ { cbl::PSX_S_IROTH, S_IROTH },
+ { cbl::PSX_S_IRWXO, S_IRWXO },
+ { cbl::PSX_S_IXGRP, S_IXGRP },
+ { cbl::PSX_S_IWGRP, S_IWGRP },
+ { cbl::PSX_S_IRGRP, S_IRGRP },
+ { cbl::PSX_S_IRWXG, S_IRWXG },
+ { cbl::PSX_S_IXUSR, S_IXUSR },
+ { cbl::PSX_S_IWUSR, S_IWUSR },
+ { cbl::PSX_S_IRUSR, S_IRUSR },
+ { cbl::PSX_S_IRWXU, S_IRWXU },
+ { cbl::PSX_S_ISVTX, S_ISVTX },
+ { cbl::PSX_S_ISGID, S_ISGID },
+ { cbl::PSX_S_ISUID, S_ISUID },
};
-
+
int flags = 0;
mode_t mode = 0;
-
+
for( auto elem : flag_bits ) {
int cbl_bit = elem.first;
int std_bit = elem.second;
-
+
if( cbl_bit == (cbl_bit & cbl_flags) ) {
flags |= std_bit;
}
for( auto elem : mode_bits ) {
int cbl_bit = elem.first;
int std_bit = elem.second;
-
+
if( cbl_bit == (cbl_bit & cbl_mode) ) {
mode |= std_bit;
}
--- /dev/null
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * This function is in the public domain.
+ * Contributed by smckinney of COBOLworx Feb 2026.
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * int ftruncate(int fd, off_t length);
+ Identification Division.
+ Function-ID. posix-ftruncate.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-fd PIC 9(8) Usage COMP.
+ 01 Lk-offset Binary-Long.
+ Procedure Division using
+ By Value Lk-fd,
+ By Value Lk-offset,
+ Returning Return-Value.
+ Display 'posix-ftruncate fd: ' Lk-fd ', Lk-offset: ' Lk-offset.
+ Call "ftruncate" using
+ By Value Lk-fd,
+ By Value Lk-offset,
+ Returning Return-Value.
+ Goback.
+ End Function posix-ftruncate.
With Debugging Mode
>>END-IF
.
-
+
Data Division.
Working-Storage Section.
77 Ws-pathname PIC X(8192).
Linkage Section.
77 Return-Value Binary-Long.
01 Lk-pathname PIC X ANY LENGTH.
- 01 Lk-flags PIC 9(8).
+ 01 Lk-flags PIC 9(8) Binary-long.
01 Lk-mode PIC 9(8).
Procedure Division using
By Reference Lk-pathname,
By Reference Lk-flags,
- By Reference Optional Lk-mode
+ By Reference Optional Lk-mode
Returning Return-Value.
Move Lk-pathname To Ws-pathname.
- Inspect Ws-pathname
+ Inspect Ws-pathname
Replacing Trailing Space By Low-Value
D Display 'posix-open: Ws-pathname ', Ws-pathname.
If ws-mode-ptr > 0 Then *> O_CREAT requires mode
Move Lk-mode to Ws-mode.
-
- Call "posix_open" using Ws-pathname, Lk-flags, Ws-mode,
+
+ Call "posix_open" using Ws-pathname,
+ By Value Lk-flags,
+ By Value Ws-mode,
Returning Return-Value.
Goback.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* This function is in the public domain.
* Contributed by James K. Lowden of COBOLworx November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* long read( int fd, void * buf, unsigned long count)
Identification Division.
Function-ID. posix-read.
Data Division.
Linkage Section.
77 Return-Value Binary-Long.
- 01 Lk-fd PIC 9(8) Usage COMP.
+ 01 Lk-fd PIC 9(8) Usage COMP-5.
01 Lk-buf PIC X ANY LENGTH.
01 Lk-count PIC 9(8) Usage COMP.
Procedure Division using
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* This function is in the public domain.
* Contributed by James K. Lowden of COBOLworx November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* long write( int fd, const void * buf, unsigned long count)
Identification Division.
Function-ID. posix-write.
Data Division.
Linkage Section.
77 Return-Value Binary-Long.
- 01 Lk-fd PIC 9(8) Usage COMP.
+ 01 Lk-fd PIC 9(8) Usage COMP-5.
01 Lk-buf PIC X ANY LENGTH.
01 Lk-count PIC 9(8) Usage COMP.
Procedure Division using
if( getenv("XMLPARSE") ) {
switch(len) {
case 0:
- fprintf(stderr, "%s:%d Kilroy was here\n", func, line);
+ fprintf(stderr, "%s:%d was here\n", func, line);
break;
case -1:
fprintf(stderr, "%s:%d: '%s'\n", func, line, data);
projects / thirdparty / gcc.git / commitdiff
