git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

cobol: Multiple PRs; formatting; exception processing. 

The PRs mentined here have either been previously fixed, or are fixed by
this commit.

gcc/cobol/ChangeLog:

	PR cobol/119770
	PR cobol/119772
	PR cobol/119790
	PR cobol/119771
	PR cobol/119810
	PR cobol/119335
	PR cobol/119632
	* cdf-copy.cc (GLOB_BRACE): Eliminate <glob.h>.
	* cdfval.h (_CDF_VAL_H_): Switch to C++ headers.
	* copybook.h (class copybook_elem_t): Eliminate <glob.h>.
	(class copybook_t): Likewise.
	* gcobc: Numerous changes to improve utility.
	* gcobol.1: Correct names in the list of functions.
	* genapi.cc (compare_binary_binary): Use has_attr() function.
	* lexio.cc (cdftext::lex_open): Typo; filename logic.
	(cdftext::process_file): Filename logic.
	* parse.y: Numerous parsing changes.
	* parse_ante.h (new_alphanumeric): C++ includes; changes to temporaries.
	(new_tempnumeric): Likewise.
	(new_tempnumeric_float): Likewise.
	(set_real_from_capacity): Created.
	* scan.l: Use yy_pop_state().
	* scan_ante.h (typed_name): Find figconst from data.initial.
	* symbols.cc (symbol_valid_udf_args): Eliminate.
	(symbols_update): figconst processing.
	(new_temporary_impl): For functions, set .initial to function name.
	(temporaries_t::acquire): Likewise.
	(new_alphanumeric): Likewise.
	(new_temporary): Likewise.
	* symbols.h (_SYMBOLS_H_): Use C++ includes.
	(cbl_figconst_tok): Change handling of figconst.
	(cbl_figconst_field_of): Change handling of figconst.
	(symbol_valid_udf_args): Eliminate.
	* symfind.cc (symbol_match2): Change declaration.
	(symbol_match): Change declaration.

libgcobol/ChangeLog:

	* charmaps.cc: Switch to C++ includes.
	* common-defs.h: Likewise.
	* constants.cc: Likewise.
	* ec.h: Remove #include <assert.h>.
	* gcobolio.h (GCOBOLIO_H_): Switch to C++ includes.
	* gfileio.cc: Likewise.
	* gmath.cc: Likewise.
	* intrinsic.cc: Comment formatting; C++ includes.
	* io.cc: C++ includes.
	* libgcobol.cc: (__gg__stash_exceptions): Eliminate.
	* valconv.cc: Switch to C++ includes.

Co-Authored-By: James K. Lowden <jklowden@cobolworx.com>
(cherry picked from commit fba34a0cc5)
This commit is contained in:
Robert Dubner 2025-05-20 13:35:15 -04:00
parent e7f1334ad0
commit 907e343138
25 changed files with 458 additions and 402 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
gcc/cobol/cdf-copy.cc
View File

@ -35,23 +35,12 @@
// We regret any confusion engendered.
#include "config.h"
#include <glob.h>
#include "cobol-system.h"
#include "cbldiag.h"
#include "util.h"
#include "copybook.h"
// GLOB_BRACE and GLOB_TILDE are BSD extensions. Provide fallback definitions
// if necessary.
#ifndef GLOB_BRACE
#define GLOB_BRACE 0
#endif
#ifndef GLOB_TILDE
#define GLOB_TILDE 0
#endif
#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
/*
@ -86,7 +75,6 @@
* space. This function only applies them.
*/
extern int yydebug;
const char * cobol_filename();
bool is_fixed_format();
bool is_reference_format();
@ -190,12 +178,6 @@ esc( size_t len, const char input[] ) {
return buffer; // caller must strdup static buffer
}
static int
glob_error(const char *epath, int eerrno) {
dbgmsg("%s: COPY file search: '%s': %s", __func__, epath, xstrerror(eerrno));
return 0;
}
void
copybook_directory_add( const char gcob_copybook[] ) {
if( !gcob_copybook ) return;
@ -242,27 +224,15 @@ copybook_extension_add( const char ext[] ) {
copybook.extensions_add( ext, alt );
}
extern int yydebug;
const char * copybook_elem_t::extensions;
std::list<const char *> copybook_elem_t::suffixes {
"", ".cpy", ".CPY", ".cbl", ".CBL", ".cob", ".COB"
};
void
copybook_t::extensions_add( const char ext[], const char alt[] ) {
char *output;
if( alt ) {
output = xasprintf("%s,%s", ext, alt);
} else {
output = xstrdup(ext);
}
gcc_assert(output);
if( book.extensions ) {
char *s = xasprintf("%s,%s", output, book.extensions);
free(const_cast<char*>(book.extensions));
free(output);
book.extensions = s;
} else {
book.extensions = output;
}
book.suffixes.push_back(ext);
if( alt ) book.suffixes.push_back(alt);
}
static inline ino_t
@ -276,9 +246,7 @@ inode_of( int fd ) {
int
copybook_elem_t::open_file( const char directory[], bool literally ) {
int erc;
char *pattern, *copier = xstrdup(cobol_filename());
char *dname = NULL;
char *dname = NULL, *copier = xstrdup(cobol_filename());
if ( directory ) {
dname = xstrdup(directory);
@ -324,52 +292,26 @@ copybook_elem_t::open_file( const char directory[], bool literally ) {
}
gcc_assert( ! literally );
if( extensions ) {
pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB,%s}",
path, this->extensions);
} else {
pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB}", path);
}
free(copier);
static int flags = GLOB_MARK | GLOB_BRACE | GLOB_TILDE;
glob_t globber;
for( auto suffix : suffixes ) {
std::string pattern(path);
pattern += suffix;
dbgmsg("%s: trying %s", __func__, pattern.c_str());
if( (erc = glob(pattern, flags, glob_error, &globber)) != 0 ) {
switch(erc) {
case GLOB_NOSPACE:
yywarn("COPY file search: out of memory");
break;
case GLOB_ABORTED:
yywarn("COPY file search: read error");
break;
case GLOB_NOMATCH:
dbgmsg("COPY '%s': no files match %s", this->source.name, pattern);
default:
break; // caller says no file found
}
return -1;
}
free(pattern);
for( size_t i=0; i < globber.gl_pathc; i++ ) {
auto filename = globber.gl_pathv[i];
auto filename = pattern.c_str();
if( (this->fd = open(filename, O_RDONLY)) != -1 ) {
dbgmsg("found copybook file %s", filename);
this->source.name = xstrdup(filename);
if( ! cobol_filename(this->source.name, inode_of(fd)) ) {
error_msg(source.loc, "recursive copybook: '%s' includes itself", this->source);
(void)! close(fd);
fd = -1;
error_msg(source.loc, "recursive copybook: '%s' includes itself", this->source);
(void)! close(fd);
fd = -1;
}
globfree(&globber);
dbgmsg("%s: opened %s as fd %d", __func__, source.name, fd);
return fd;
}
}
yywarn("could not open copy source for '%s'", source);
globfree(&globber);
return -1;
}

6
gcc/cobol/cdfval.h
View File

@ -32,9 +32,9 @@
#ifndef _CDF_VAL_H_
#define _CDF_VAL_H_
#include <assert.h>
#include <stdint.h>
#include <stdlib.h>
#include <cassert>
#include <cstdint>
#include <cstdlib>
bool scanner_parsing();

13
gcc/cobol/copybook.h
View File

@ -65,7 +65,7 @@ class copybook_elem_t {
copybook_loc_t() : name(NULL) {}
} source, library;
bool suppress;
static const char *extensions;
static std::list<const char *> suffixes;
public:
struct { bool source, library; } literally;
int fd;
@ -91,7 +91,6 @@ class copybook_elem_t {
}
int open_file( const char dir[], bool literally = false );
void extensions_add( const char ext[], const char alt[] );
static inline bool is_quote( const char ch ) {
return ch == '\'' || ch == '"';
@ -185,12 +184,10 @@ class copybook_t {
this->source(loc, name);
for( auto dir : directories ) {
if( true ) {
dbgmsg("copybook_t::open '%s' OF '%s' %s",
book.source.name,
dir? dir: ".",
book.literally.source? ", literally" : "" );
}
dbgmsg("copybook_t::open '%s' OF '%s' %s",
book.source.name,
dir? dir: ".",
book.literally.source? ", literally" : "" );
if( (fd = book.open_file(dir, book.literally.source)) != -1 ) break;
}
return fd;

141
gcc/cobol/gcobc
View File

@ -73,7 +73,7 @@ fi
exit_status=0
skip_arg=
opts="-dialect gnu $copydir ${dialect:--dialect mf} $includes"
opts="$copydir $includes"
mode=-shared
incomparable="has no comparable gcobol option"
@ -103,6 +103,9 @@ $0 recognizes the following GnuCOBOL cobc output mode options:
$0 recognizes the following GnuCOBOL cobc compilation options:
-C
-d, --debug
-D
-A
-Q
-E
-g
--coverage
@ -112,24 +115,29 @@ $0 recognizes the following GnuCOBOL cobc compilation options:
--fixed
-F, --free
-fimplicit-init
-h, --help
-save-temps=
-save-temps
-std=mvs
-std=mf
Options that are the same in gcobol and cobc are passed through verbatim.
Options that have no analog in gcobol produce a warning message.
To produce this message, use -HELP.
-h, --help
-save-temps=
-save-temps
-std=mvs -std=mvs-strict
-std=mf -std=mf-strict
-std=cobol85 -std=cobol2002 -std=cobol2014
Options that are the same in gcobol and cobc are passed through verbatim.
Options that have no analog in gcobol produce a warning message.
To produce this message, use -HELP.
To see the constructed cobc command-line, use -echo.
To override the default cobc, set the "cobc" environment variable.
By default, gcobc invokes the gcobol the same directory the gcobc resides.
To override, set the gcobol environment variable.
EOF
}
EOF
}
#
# Simply iterate over the command-line tokens. We can't use getopts
# here because it's not designed for single-dash words (e.g. -shared).
dialect="gnu"
out_set=""
first=""
#
# Simply iterate over the command-line tokens. We can't use getopts
# here because it's not designed for single-dash words (e.g. -shared).
#
for opt in "$@"
@ -147,41 +155,52 @@ do
;;
esac
opts="$opts $pending_arg $opt"
opts="$opts $pending_arg$opt"
pending_arg=
continue
fi
case $opt in
-A | -Q) warn "$opt"
;;
# pass next parameter to GCC
-A)
pending_arg=" "
;;
# pass next parameter to linker
-Q)
pending_arg=-Wl,
;;
-b) mode="-shared"
;;
-c) mode="-c"
;;
--conf=*) warn "$opt"
;;
-C) error "$opt $incomparable"
;;
-C) error "$opt $incomparable"
;;
-d | -debug | --debug) opts="$opts -fcobol-exceptions=EC-ALL"
warn "$opt implies -fstack-check:"
;;
# define for preprocessor, note: -D* is directly passed
-D)
pending_arg=$opt
;;
-d | --debug) opts="$opts -fcobol-exceptions=EC-ALL"
warn "$opt implies -fstack-check:"
;;
# -D
-E) opts="$opts $opt -fsyntax-only"
;;
-echo) echo="echo"
-E) opts="$opts $opt -fsyntax-only"
;;
-echo) echo="echo"
;;
-fec=* | -fno-ec=*)
opt="$(echo "$opt" | sed -E 's/-f(no-)?ec=/-f\1cobol-exceptions=EC-/g')"
opts="$opts $opt"
;;
-ext)
pending_arg=$opt
;;
-ext=*) opts="$opts $(echo "$opt" | sed 's/-ext=/-copyext ./')"
;;
opts="$opts $opt"
;;
-ext)
pending_arg="$opt "
;;
-ext=*) opts="$opts $(echo "$opt" | sed 's/-ext=/-copyext ./')"
;;
# A.3 Compiler options
-fsign=*) warn "$opt" ;;
-ffold-copy=*) warn "$opt" ;;
@ -359,19 +378,18 @@ do
-fnot-register=*) warn "$opt" ;;
-fregister=*) warn "$opt" ;;
-fformat=auto ) ;; # gcobol and gnucobol default
-fformat=auto) ;; # gcobol and gnucobol default
-fixed | --fixed | -fformat=fixed | -fformat=variable | -fformat=xcard)
# note: variable + xcard are only _more similar_ to fixed than free,
# (with changing right-column to 250/255, which isn't supported in gcobol, yet)
opts="$opts -ffixed-form"
;;
-F | -free | --free | -fformat=free | -fformat=* )
# note: "all other formats" are only _more similar_ to free than fixed
opts="$opts -ffree-form"
;;
opts="$opts -ffixed-form"
;;
-F | -free | --free | -fformat=free | -fformat=*)
# note: "all other formats" are only _more similar_ to free than fixed
opts="$opts -ffree-form"
;;
-h | --help) opts="$opts --help"
;;
@ -413,24 +431,35 @@ do
export GCOBOL_TEMPDIR="$opt"
;;
-save-temps) export GCOBOL_TEMPDIR="${PWD:-$(pwd)}"
;;
# -shared is identical
;;
# -shared is identical
-std=mvs) opts="$opts -dialect ibm"
-std=mvs | -std=mvs-strict | -std=ibm | -std=ibm-strict) dialect=ibm
;;
-std=mf) opts="$opts -dialect mf"
-std=mf | -std=mf-strict) dialect=mf
;;
-t | -T | -tlines=* | -P | -P=* | -X | --Xref)
warn "$opt (no listing)"
-std=default) dialect=gnu # that's GnuCOBOL's default and GCC's dialect for GnuCOBOL
;;
-std=cobol*) dialect="" # GCC COBOL targets COBOL2024 "mostly backward to COBOL85"
;;
-std=*)
dialect=""
warn "$opt (unkown dialect)"
;;
-P | -P=* | -X | --Xref)
warn "$opt (no listing)"
;;
-t | -T)
# note: -P has an _optional_ arg, so we leave it above
ignore_arg "$opt (no listing)"
;;
-q | --brief) warn "$opt"
;;
-v | --verbose) opts="$opts -V"
;;
# note: we want -dumpversion to be passed to gcc
-V | --version | -version) opts="$opts --version"
;;
-q | --brief) warn "$opt"
;;
-v | --verbose) opts="$opts -V"
;;
# note: we want -dumpversion to be passed to gcc
-V | --version | -version) opts="$opts --version"
;;
# pass through, strangely -Wall is not supported
-w | -W | -Wextra) opts="$opts $opt"
;;

54
gcc/cobol/gcobol.1
View File

@ -1167,54 +1167,54 @@ others. They are listed alphabetically below.
.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

4
gcc/cobol/genapi.cc
View File

@ -1969,8 +1969,8 @@ compare_binary_binary(tree return_int,
{
gg_printf("compare_binary_binary(): using int64\n", NULL_TREE);
}
left_side = gg_define_variable( left_side_ref->field->attr & signable_e ? LONG : ULONG );
right_side = gg_define_variable(right_side_ref->field->attr & signable_e ? LONG : ULONG );
left_side = gg_define_variable( left_side_ref->field->has_attr(signable_e) ? LONG : ULONG );
right_side = gg_define_variable(right_side_ref->field->has_attr(signable_e) ? LONG : ULONG );
}
//tree dummy = gg_define_int();

7
gcc/cobol/lexio.cc
View File

@ -1455,7 +1455,7 @@ cdftext::lex_open( const char filename[] ) {
int output = open_output();
// Process any files supplied by the -include comamnd-line option.
// Process any files supplied by the -include command-line option.
for( auto name : included_files ) {
int input;
if( -1 == (input = open(name, O_RDONLY)) ) {
@ -1466,7 +1466,10 @@ cdftext::lex_open( const char filename[] ) {
filespan_t mfile( free_form_reference_format( input ) );
process_file( mfile, output );
cobol_filename_restore(); // process_file restores only for COPY
}
included_files.clear();
cobol_filename(filename, inode_of(input));
filespan_t mfile( free_form_reference_format( input ) );
@ -1831,6 +1834,7 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) {
// indicate current file
static const char file_push[] = "\f#FILE PUSH ", file_pop[] = "\f#FILE POP\f";
if( !included_files.empty() ) { ++nfiles; }; // force push/pop of included filename
if( !second_pass && nfiles++ ) {
static const char delimiter[] = "\f";
const char *filename = cobol_filename();
@ -1918,6 +1922,7 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) {
std::copy(file_pop, file_pop + strlen(file_pop), ofs);
out.flush();
}
if( !included_files.empty() ) { --nfiles; };
}
std::list<span_t>

283
gcc/cobol/parse.y
View File

@ -375,7 +375,7 @@
LSUB "("
PARAMETER_kw "PARAMETER"
OVERRIDE READY RESET
RSUB ")"
RSUB")"
SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL"
SUBSCRIPT SUPPRESS TITLE TRACE USE
@ -662,7 +662,7 @@
%type <boolean> all optional sign_leading on_off initialized strong is_signed
%type <number> count data_clauses data_clause
%type <number> nine nines nps relop spaces_etc reserved_value signed
%type <number> variable_type
%type <number> variable_type binary_type
%type <number> true_false posneg eval_posneg
%type <number> open_io alphabet_etc
%type <special_type> device_name
@ -951,7 +951,7 @@
%printer { fprintf(yyo, "%s'%.*s'{" HOST_SIZE_T_PRINT_UNSIGNED "} %s",
$$.prefix, int($$.len), $$.data, (fmt_size_t)$$.len,
$$.symbol_name()); } <literal>
%printer { fprintf(yyo, "%s (1st of " HOST_SIZE_T_PRINT_UNSIGNED ")",
%printer { fprintf(yyo,"%s (1st of" HOST_SIZE_T_PRINT_UNSIGNED")",
$$->targets.empty()? "" : $$->targets.front().refer.field->name,
(fmt_size_t)$$->targets.size() ); } <targets>
%printer { fprintf(yyo, "#" HOST_SIZE_T_PRINT_UNSIGNED ": %s",
@ -1559,7 +1559,7 @@ opt_clause: opt_arith
| opt_entry
| opt_binary
| opt_decimal {
cbl_unimplementedw("type FLOAT-DECIMAL was ignored");
cbl_unimplemented("type FLOAT-DECIMAL");
}
| opt_intermediate
| opt_init
@ -2948,7 +2948,7 @@ fd_clause: record_desc
{
auto f = cbl_file_of(symbol_at(file_section_fd));
f->attr |= external_e;
cbl_unimplemented("AS LITERAL ");
cbl_unimplemented("AS LITERAL");
}
| fd_linage
| fd_report {
@ -3362,9 +3362,11 @@ data_descr: data_descr1
;
const_value: cce_expr
| BYTE_LENGTH of name { $name->data.set_real_from_capacity(&$$); }
| LENGTH of name { $name->data.set_real_from_capacity(&$$); }
| LENGTH_OF of name { $name->data.set_real_from_capacity(&$$); }
| BYTE_LENGTH of name { set_real_from_capacity(@name, $name, &$$); }
| LENGTH of name { set_real_from_capacity(@name, $name, &$$); }
| LENGTH_OF of name { set_real_from_capacity(@name, $name, &$$); }
| LENGTH_OF of binary_type[type] {
real_from_integer(&$$, VOIDmode, $type, SIGNED); }
;
value78: literalism
@ -3380,6 +3382,12 @@ value78: literalism
data = build_real (float128_type_node, $1);
$$ = new cbl_field_data_t(data);
}
| reserved_value[value]
{
auto field = constant_of(constant_index($value));
$$ = new cbl_field_data_t(field->data);
}
| true_false
{
cbl_unimplemented("Boolean constant");
@ -3413,6 +3421,21 @@ data_descr1: level_name
error_msg(@1, "%s was defined by CDF", field.name);
}
}
| level_name CONSTANT is_global as reserved_value[value]
{
cbl_field_t& field = *$1;
if( field.level != 1 ) {
error_msg(@1, "%s must be an 01-level data item", field.name);
YYERROR;
}
field.attr |= constant_e;
if( $is_global ) field.attr |= global_e;
field.type = FldLiteralA;
auto fig = constant_of(constant_index($value));
field.data = fig->data;
}
| level_name CONSTANT is_global as literalism[lit]
{
cbl_field_t& field = *$1;
@ -3452,8 +3475,8 @@ data_descr1: level_name
| LEVEL78 NAME[name] VALUE is value78[data]
{
if( ! dialect_mf() ) {
dialect_error(@1, "level 78", "mf");
if( ! (dialect_mf() || dialect_gnu()) ) {
dialect_error(@1, "level 78", "mf or gnu");
YYERROR;
}
struct cbl_field_t field = { 0, FldLiteralA, FldInvalid,
@ -5038,7 +5061,7 @@ accept: accept_body end_accept {
switch( $accept_body.func ) {
case accept_done_e:
error_msg(@ec, "ON EXCEPTION valid only "
"with ENVIRONMENT or COMAMND-LINE(n)");
"with ENVIRONMENT or COMMAND-LINE(n)");
break;
case accept_command_line_e:
if( $1.from->field == NULL ) { // take next command-line arg
@ -5050,7 +5073,7 @@ accept: accept_body end_accept {
parser_move(*$1.into, *$1.from);
if( $ec.on_error || $ec.not_error ) {
error_msg(@ec, "ON EXCEPTION valid only "
"with ENVIRONMENT or COMAMND-LINE(n)");
"with ENVIRONMENT or COMMAND-LINE(n)");
}
} else {
parser_accept_command_line(*$1.into, *$1.from,
@ -7025,6 +7048,15 @@ num_value: scalar // might actually be a string
| num_literal { $$ = new_reference($1); }
| ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
| DETAIL OF scalar {$$ = $scalar; }
| LENGTH_OF binary_type[size] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
$$->field->clear_attr(signable_e);
if( dialect_gcc() ) {
dialect_error(@1, "LENGTH OF", "ibm");
}
parser_set_numeric($$->field, $size);
}
| LENGTH_OF name[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
@ -7251,6 +7283,15 @@ signed_literal: num_literal
struct cbl_field_t *zero = constant_of(constant_index(ZERO));
parser_subtract( $$, zero, $2, current_rounded_mode() );
}
| LENGTH_OF binary_type[size] {
location_set(@1);
$$ = new_tempnumeric();
$$->clear_attr(signable_e);
if( dialect_gcc() ) {
dialect_error(@1, "LENGTH OF", "ibm");
}
parser_set_numeric($$, $size);
}
| LENGTH_OF name[val] {
location_set(@1);
$$ = new_tempnumeric();
@ -7505,6 +7546,7 @@ perform_inline: perform_start statements END_PERFORM
}
}
;
perform_start: %empty %prec LOCATION {
perform_ec_setup();
$$ = 0;
@ -7809,6 +7851,15 @@ varg1a: ADDRESS OF scalar {
{
$$ = new_reference(constant_of(constant_index($1)));
}
| LENGTH_OF binary_type[size] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
$$->field->clear_attr(signable_e);
if( dialect_gcc() ) {
dialect_error(@1, "LENGTH OF", "ibm");
}
parser_set_numeric($$->field, $size);
}
| LENGTH_OF name[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
@ -7833,6 +7884,10 @@ varg1a: ADDRESS OF scalar {
}
;
binary_type: BINARY_INTEGER { $$ = $1.capacity; }
| COMPUTATIONAL { $$ = $1.capacity; }
;
literal: literalism
{
$$ = $1.isymbol()?
@ -10108,7 +10163,9 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
if( ! current.udf_args_valid(L, $args->refers, params) ) {
YYERROR;
}
$$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
const auto returning = cbl_field_of(symbol_at(L->returning));
$$ = new_temporary_clone(returning);
$$->data.initial = returning->name; // user's name for the field
std::vector <cbl_ffi_arg_t> args($args->refers.size());
size_t i = 0;
// Pass parameters as defined by the function.
@ -10127,7 +10184,9 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
static cbl_ffi_arg_t *args = NULL;
auto L = cbl_label_of(symbol_at($1));
$$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
const auto returning = cbl_field_of(symbol_at(L->returning));
$$ = new_temporary_clone(returning);
$$->data.initial = returning->name; // user's name for the field
auto name = new_literal(strlen(L->name), L->name, quoted_e);
ast_call( @1, name, $$, narg, args, NULL, NULL, true );
@ -10168,7 +10227,7 @@ intrinsic: function_udf
$$ = is_numeric(args[0].field)?
new_tempnumeric_float() :
new_alphanumeric();
$$->data.initial = keyword_str($1);
parser_intrinsic_callv( $$, intrinsic_cname($1),
args.size(), args.data() );
}
@ -10177,7 +10236,7 @@ intrinsic: function_udf
{
static char s[] = "__gg__present_value";
location_set(@1);
$$ = new_tempnumeric_float();
$$ = new_tempnumeric_float("PRESENT-VALUE");
size_t n = $args->size();
assert(n > 0);
if( n < 2 ) {
@ -10195,48 +10254,48 @@ intrinsic: function_udf
| BASECONVERT '(' varg[r1] varg[r2] varg[r3] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("BASECONVERT");
cbl_unimplemented("BASECONVERT");
if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR;
}
| BIT_OF '(' expr[r1] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("BIT-OF");
if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR;
}
| CHAR '(' expr[r1] ')' {
location_set(@1);
$$ = new_alphanumeric(1);
$$ = new_alphanumeric(1,"CHAR");
if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR;
}
| CONVERT '(' varg[r1] convert_src[src] convert_dst[dst] ')' {
location_set(@1);
$$ = new_alphanumeric(1);
$$ = new_alphanumeric(1,"CONVERT");
cbl_unimplemented("CONVERT");
/* if( ! intrinsic_call_3($$, CONVERT, $r1, $src, $dst) ) YYERROR; */
}
| DISPLAY_OF '(' varg[r1] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("DISPLAY-OF");
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR;
}
| DISPLAY_OF '(' varg[r1] varg[r2] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("DISPLAY-OF");
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR;
}
| EXCEPTION_FILE filename {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-FILE");
parser_exception_file( $$, $filename );
}
| FIND_STRING '(' varg[r1] last start_after anycase ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("FIND-STRING");
/* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */
cbl_unimplemented("FIND_STRING");
/* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */
@ -10244,7 +10303,7 @@ intrinsic: function_udf
| FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE, "FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR;
}
@ -10253,7 +10312,7 @@ intrinsic: function_udf
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
static cbl_refer_t r3(literally_zero);
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
@ -10262,7 +10321,7 @@ intrinsic: function_udf
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] expr[r4] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
r1, $r2, $r3, $r4) ) YYERROR;
@ -10273,14 +10332,14 @@ intrinsic: function_udf
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_3($$, FORMATTED_TIME,
r1, $r2, $r3) ) YYERROR;
}
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-TIME");
auto r3 = new_reference(new_literal("0"));
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_3($$, FORMATTED_TIME,
@ -10288,21 +10347,21 @@ intrinsic: function_udf
}
| FORMATTED_CURRENT_DATE '(' DATETIME_FMT[r1] ')' {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-CURRENT_DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1, @r1) )
YYERROR;
}
| TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
| TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
@ -10310,14 +10369,14 @@ intrinsic: function_udf
| TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
| INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
@ -10325,14 +10384,14 @@ intrinsic: function_udf
| INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
}
| SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
r1, $r2) ) YYERROR;
@ -10340,7 +10399,7 @@ intrinsic: function_udf
| SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
r1, $r2) ) YYERROR;
@ -10348,85 +10407,85 @@ intrinsic: function_udf
| HEX_OF '(' varg[r1] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("HEX-OF");
if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR;
}
| LENGTH '(' tableish[val] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("LENGTH");
$$->clear_attr(signable_e);
parser_set_numeric($$, $val->field->size());
if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
}
| LENGTH '(' varg1a[val] ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("LENGTH");
$$->clear_attr(signable_e);
parser_set_numeric($$, $val->field->data.capacity);
if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
}
| lopper_case[func] '(' alpha_val[r1] ')' {
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
$$ = new_alphanumeric($r1->field->data.capacity, "lopper_case[func]");
if( ! intrinsic_call_1($$, $func, $r1, @r1)) YYERROR;
}
| MODULE_NAME '(' module_type[type] ')'
{
$$ = new_alphanumeric(sizeof(cbl_name_t));
$$ = new_alphanumeric(sizeof(cbl_name_t), "MODULE-NAME");
parser_module_name( $$, $type );
}
| NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("NUMVAL-C");
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase );
}
| ORD '(' alpha_val[r1] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("ORD");
if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR;
}
| RANDOM
{
location_set(@1);
$$ = new_tempnumeric_float();
$$ = new_tempnumeric_float("RANDOM");
parser_intrinsic_call_0( $$, intrinsic_cname(RANDOM) );
}
| RANDOM_SEED expr[r1] ')'
{ // left parenthesis consumed by lexer
location_set(@1);
$$ = new_tempnumeric_float();
$$ = new_tempnumeric_float("RANDOM-SEED");
if( ! intrinsic_call_1($$, RANDOM, $r1, @r1)) YYERROR;
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] varg[r4] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("SUBSTITUTE");
std::vector <cbl_substitute_t> args($inputs->size());
std::transform( $inputs->begin(), $inputs->end(), args.begin(),
[]( const substitution_t& arg ) {
@ -10442,7 +10501,7 @@ intrinsic: function_udf
| TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("parser_intrinsic_subst($$,");
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase, true );
}
@ -10469,14 +10528,14 @@ intrinsic: function_udf
YYERROR;
break;
}
$$ = new_alphanumeric();
$$ = new_alphanumeric("TRIM");
cbl_refer_t * how = new_reference($trim_trailing);
if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR;
}
| USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("USUBSTR");
if( ! intrinsic_call_3($$, FORMATTED_DATETIME,
$r1, $r2, $r3) ) YYERROR;
}
@ -10484,14 +10543,14 @@ intrinsic: function_udf
| intrinsic_I '(' expr[r1] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric(keyword_str($1));
if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
}
| intrinsic_N '(' expr[r1] ')'
{
location_set(@1);
$$ = new_tempnumeric_float();
$$ = new_tempnumeric_float(keyword_str($1));
if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
}
@ -10501,17 +10560,14 @@ intrinsic: function_udf
auto type = intrinsic_return_type($1);
switch(type) {
case FldAlphanumeric:
$$ = new_alphanumeric();
$$ = new_alphanumeric(keyword_str($1));
break;
default:
if( $1 == NUMVAL || $1 == NUMVAL_F )
{
$$ = new_temporary(FldFloat);
}
else
{
$$ = new_temporary(type);
}
if( $1 == NUMVAL || $1 == NUMVAL_F ) {
$$ = new_temporary(FldFloat, keyword_str($1));
} else {
$$ = new_temporary(type, keyword_str($1));
}
}
if( $1 == NUMVAL_F ) {
if( is_literal($r1->field) && ! is_numeric($r1->field->type) ) {
@ -10526,7 +10582,7 @@ intrinsic: function_udf
| intrinsic_I2 '(' expr[r1] expr[r2] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("intrinsic_I2");
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
@ -10542,7 +10598,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, r2, r3) ) YYERROR;
}
@ -10558,7 +10614,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, $r2, r3) ) YYERROR;
}
@ -10567,7 +10623,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, $r2, $r3) ) YYERROR;
}
@ -10584,7 +10640,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, r2, r3) ) YYERROR;
}
@ -10600,7 +10656,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, $r2, r3) ) YYERROR;
}
@ -10609,7 +10665,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, $r2, $r3) ) YYERROR;
}
@ -10626,7 +10682,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, r2, r3) ) YYERROR;
}
@ -10642,7 +10698,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
$$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, $r2, r3) ) YYERROR;
}
@ -10651,7 +10707,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, $r2, $r3) ) YYERROR;
}
@ -10659,25 +10715,25 @@ intrinsic: function_udf
| intrinsic_N2 '(' expr[r1] expr[r2] ')'
{
location_set(@1);
switch($1)
{
case ANNUITY:
$$ = new_tempnumeric_float();
break;
case COMBINED_DATETIME:
$$ = new_tempnumeric();
break;
case REM:
$$ = new_tempnumeric_float();
break;
}
switch($1) {
case ANNUITY:
$$ = new_tempnumeric_float();
break;
case COMBINED_DATETIME:
$$ = new_tempnumeric();
break;
case REM:
$$ = new_tempnumeric_float();
break;
}
$$->data.initial = keyword_str($1); // function name
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
| intrinsic_X2 '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric(keyword_str($1));
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
| intrinsic_locale
@ -10788,65 +10844,66 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both
intrinsic0: CURRENT_DATE {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE);
$$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "CURRENT-DATE");
parser_intrinsic_call_0( $$, "__gg__current_date" );
}
| E {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("E");
parser_intrinsic_call_0( $$, "__gg__e" );
}
| EXCEPTION_FILE_N {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-FILE-N");
intrinsic_call_0( $$, EXCEPTION_FILE_N );
}
| EXCEPTION_FILE {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-FILE");
parser_exception_file( $$ );
}
| EXCEPTION_LOCATION_N {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-LOCATION-N");
intrinsic_call_0( $$, EXCEPTION_LOCATION_N );
}
| EXCEPTION_LOCATION {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-LOCATION");
intrinsic_call_0( $$, EXCEPTION_LOCATION );
}
| EXCEPTION_STATEMENT {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-STATEMENT");
intrinsic_call_0( $$, EXCEPTION_STATEMENT );
}
| EXCEPTION_STATUS {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("EXCEPTION-STATUS");
intrinsic_call_0( $$, EXCEPTION_STATUS );
}
| PI {
location_set(@1);
$$ = new_tempnumeric_float();
$$ = new_tempnumeric_float("PI");
parser_intrinsic_call_0( $$, "__gg__pi" );
}
| SECONDS_PAST_MIDNIGHT {
location_set(@1);
$$ = new_tempnumeric();
$$ = new_tempnumeric("SECONDS-PAST-MIDNIGHT");
intrinsic_call_0( $$, SECONDS_PAST_MIDNIGHT );
}
| UUID4 {
location_set(@1);
$$ = new_alphanumeric();
$$ = new_alphanumeric("UUID4");
parser_intrinsic_call_0( $$, "__gg__uuid4" );
}
| WHEN_COMPILED {
location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); // Returns YYYYMMDDhhmmssss-0500
// Returns YYYYMMDDhhmmssss-0500)
$$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "WHEN-COMPILED");
parser_intrinsic_call_0( $$, "__gg__when_compiled" );
}
;
@ -12879,6 +12936,34 @@ cbl_figconst_of( const char *value ) {
return p == eovalues? normal_value_e : p->type;
}
int
cbl_figconst_tok( const char *value ) {
struct values_t {
const char *value; int token;
} static const values[] = {
{ constant_of(constant_index(ZERO))->data.initial, ZERO },
{ constant_of(constant_index(SPACES))->data.initial, SPACES },
{ constant_of(constant_index(HIGH_VALUES))->data.initial, HIGH_VALUES },
{ constant_of(constant_index(LOW_VALUES))->data.initial, LOW_VALUES },
{ constant_of(constant_index(QUOTES))->data.initial, QUOTES },
{ constant_of(constant_index(NULLS))->data.initial, NULLS },
}, *eovalues = values + COUNT_OF(values);
auto p = std::find_if( values, eovalues,
[value]( const values_t& elem ) {
return elem.value == value;
} );
return p == eovalues? 0 : p->token;
}
const cbl_field_t *
cbl_figconst_field_of( const char *value ) {
int token = cbl_figconst_tok(value);
return token == 0 ? nullptr : constant_of(constant_index(token));
}
cbl_field_attr_t
literal_attr( const char prefix[] ) {
switch(strlen(prefix)) {

35
gcc/cobol/parse_ante.h
View File

@ -28,9 +28,9 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <assert.h>
#include <string.h>
#include <stdio.h>
#include <cassert>
#include <cstring>
#include <cstdio>
#include <algorithm>
#include <list>
@ -109,7 +109,7 @@ void input_file_status_notify();
int yylex(void);
extern int yydebug;
#include <stdarg.h>
#include <cstdarg>
const char *
consistent_encoding_check( const YYLTYPE& loc, const char input[] ) {
@ -223,7 +223,13 @@ namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) {
}
cbl_field_t *
new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH );
new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH,
const cbl_name_t name = nullptr );
static inline cbl_field_t *
new_alphanumeric( const cbl_name_t name ) {
return new_alphanumeric(MAXIMUM_ALPHA_LENGTH, name);
}
static inline cbl_refer_t *
new_reference( enum cbl_field_type_t type, const char *initial ) {
@ -2439,10 +2445,14 @@ char *
normalize_picture( char picture[] );
static inline cbl_field_t *
new_tempnumeric(void) { return new_temporary(FldNumericBin5); }
new_tempnumeric(const cbl_name_t name = nullptr) {
return new_temporary(FldNumericBin5, name);
}
static inline cbl_field_t *
new_tempnumeric_float(void) { return new_temporary(FldFloat); }
new_tempnumeric_float(const cbl_name_t name = nullptr) {
return new_temporary(FldFloat, name);
}
uint32_t
type_capacity( enum cbl_field_type_t type, uint32_t digits );
@ -3138,6 +3148,17 @@ current_field(cbl_field_t * field = NULL) {
return local;
}
static void
set_real_from_capacity( const YYLTYPE& loc,
cbl_field_t *field,
REAL_VALUE_TYPE *r ) {
if( field == current_field() ) {
error_msg(loc, "cannot define %s via self-reference", field->name);
return;
}
field->data.set_real_from_capacity(r);
}
static struct cbl_special_name_t *
special_of( const char F[], int L, const char name[] ) {
struct symbol_elem_t *e = symbol_special(PROGRAM, name);

2
gcc/cobol/scan.l
View File

@ -275,7 +275,7 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div);
IS { pop_return IS; }
OPTIONS { yy_pop_state(); myless(0); }
[[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE)[[:blank:]]+DIVISION/.+\n {
[[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION/[[:space:].] {
yy_pop_state(); myless(0); }
[[:blank:]]*AUTHOR[[:blank:].]+{EOL}? {
// Might not have an EOL, but stop on one.

4
gcc/cobol/scan_ante.h
View File

@ -737,6 +737,10 @@ typed_name( const char name[] ) {
{
auto f = cbl_field_of(e);
if( is_constant(f) ) {
if( f->data.initial ) {
int token = cbl_figconst_tok(f->data.initial);
if( token ) return token;
}
int token = datetime_format_of(f->data.initial);
if( token ) {
yylval.string = xstrdup(f->data.initial);

63
gcc/cobol/symbols.cc
View File

@ -257,43 +257,6 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv,
} while(0)
cbl_field_t *
symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
auto L = cbl_label_of(symbol_at(function));
if( ! L->returning ) {
dbgmsg("logic error: %s does not define RETURNING", L->name);
return NULL;
}
auto e = std::find_if( symbol_at(function), symbols_end(),
[]( auto symbol ) {
if( symbol.type == SymDataSection ) {
auto section(symbol.elem.section);
return section.type == linkage_sect_e;
}
return false;
} );
for( auto arg : args ) {
size_t iarg(1);
e++; // skip over linkage_sect_e, which appears after the function
if( e->type != SymField ) {
ERROR_FIELD(arg.field,
"FUNCTION %s has no defined parameter matching arg %zu, '%s'",
L->name, iarg, arg.field->name );
return NULL;
}
auto tgt = cbl_field_of(e);
if( ! valid_move(tgt, arg.field) ) {
ERROR_FIELD(tgt, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
L->name, iarg, arg.field->pretty_name(),
tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
return NULL;
}
}
return cbl_field_of(symbol_at(L->returning));
}
static const struct cbl_occurs_t nonarray = cbl_occurs_t();
#if 0
@ -1847,6 +1810,15 @@ symbols_update( size_t first, bool parsed_ok ) {
if( field->level == 0 && field->is_key_name() ) continue;
if( is_literal(field) && field->var_decl_node != NULL ) continue;
// If the field is a constant for a figconstant, just use it.
if( field->level != 0 && field->has_attr(constant_e) ) {
auto fig = cbl_figconst_field_of(field->data.initial);
if( fig ) {
field->var_decl_node = fig->var_decl_node;
continue;
}
}
if( field->is_typedef() ) {
auto isym = end_of_group( symbol_index(p) );
p = symbol_at(--isym);
@ -3161,7 +3133,7 @@ using std::deque;
static deque<cbl_field_t*> stack;
static cbl_field_t *
new_temporary_impl( enum cbl_field_type_t type )
new_temporary_impl( enum cbl_field_type_t type, const cbl_name_t name = nullptr )
{
extern int yylineno;
static int nstack, nliteral;
@ -3238,6 +3210,8 @@ new_temporary_impl( enum cbl_field_type_t type )
snprintf(f->name, sizeof(f->name), "_stack%d",++nstack);
}
f->data.initial = name; // capture e.g. the function name
return f;
}
@ -3360,11 +3334,11 @@ temporaries_t::reuse( cbl_field_type_t type ) {
}
cbl_field_t *
temporaries_t::acquire( cbl_field_type_t type ) {
temporaries_t::acquire( cbl_field_type_t type, const cbl_name_t name ) {
cbl_field_t *field = reuse(type);
if( !field ) {
field = new_temporary_impl(type);
field = new_temporary_impl(type, name);
add(field);
}
return parser_symbol_add2(field); // notify of reuse
@ -3397,8 +3371,8 @@ symbol_temporaries_free() {
}
cbl_field_t *
new_alphanumeric( size_t capacity ) {
cbl_field_t * field = new_temporary_impl(FldAlphanumeric);
new_alphanumeric( size_t capacity, const cbl_name_t name = nullptr ) {
cbl_field_t * field = new_temporary_impl(FldAlphanumeric, name);
field->data.capacity = capacity;
temporaries.add(field);
return parser_symbol_add2(field);
@ -3408,15 +3382,14 @@ cbl_field_t *
new_temporary( enum cbl_field_type_t type, const char *initial ) {
if( ! initial ) {
assert( ! is_literal(type) ); // Literal type must have literal value.
return temporaries.acquire(type);
return temporaries.acquire(type, initial);
}
if( is_literal(type) ) {
auto field = temporaries.literal(initial,
type == FldLiteralA? quoted_e : none_e);
return field;
}
cbl_field_t *field = new_temporary_impl(type);
field->data.capacity = strlen(field->data.initial = initial);
cbl_field_t *field = new_temporary_impl(type, initial);
temporaries.add(field);
parser_symbol_add(field);

19
gcc/cobol/symbols.h
View File

@ -32,11 +32,11 @@
#else
#define _SYMBOLS_H_
#include <assert.h>
#include <limits.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <cassert>
#include <climits>
#include <cstdint>
#include <cstdlib>
#include <cstring>
#include <algorithm>
#include <list>
@ -149,6 +149,7 @@ is_working_storage(uint32_t attr) {
return 0 == (attr & (linkage_e | local_e));
}
int cbl_figconst_tok( const char *value );
enum cbl_figconst_t cbl_figconst_of( const char *value );
const char * cbl_figconst_str( cbl_figconst_t fig );
@ -631,6 +632,8 @@ struct cbl_field_t {
}
};
const cbl_field_t * cbl_figconst_field_of( const char *value );
// Necessary forward referencea
struct cbl_label_t;
struct cbl_refer_t;
@ -1191,7 +1194,7 @@ class temporaries_t {
public:
cbl_field_t * literal( const char value[], uint32_t len, cbl_field_attr_t attr = none_e );
cbl_field_t * reuse( cbl_field_type_t type );
cbl_field_t * acquire( cbl_field_type_t type );
cbl_field_t * acquire( cbl_field_type_t type, const cbl_name_t name = nullptr );
cbl_field_t * add( cbl_field_t *field );
bool keep( cbl_field_t *field ) { return 1 == used[field->type].erase(field); }
void dump() const;
@ -2353,10 +2356,6 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src );
size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files );
cbl_field_t *
symbol_valid_udf_args( size_t function,
std::list<cbl_refer_t> args = std::list<cbl_refer_t>() );
bool symbol_currency_add( const char symbol[], const char sign[] = NULL );
const char * symbol_currency( char symbol );

4
gcc/cobol/symfind.cc
View File

@ -421,7 +421,7 @@ size_t end_of_group( size_t igroup );
static std::vector<size_t>
symbol_match2( size_t program,
std::list<const char *> names, bool local = true )
const std::list<const char *>& names, bool local = true )
{
std::vector<size_t> fields;
@ -488,7 +488,7 @@ symbol_match2( size_t program,
* N-1.
*/
static symbol_map_t
symbol_match( size_t program, std::list<const char *> names ) {
symbol_match( size_t program, const std::list<const char *>& names ) {
auto matched = symbol_match2( program, names );
symbol_map_t output;

14
libgcobol/charmaps.cc
View File

@ -29,14 +29,16 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include <time.h>
#include <iconv.h>
#include <cctype>
#include <clocale>
#include <cstdio>
#include <cstring>
#include <ctime>
#include <algorithm>
#include <unordered_map>
#include <locale.h>
#include <iconv.h>
#include <vector>
#include "ec.h"

5
libgcobol/common-defs.h
View File

@ -30,8 +30,9 @@
#ifndef COMMON_DEFS_H_
#define COMMON_DEFS_H_
#include <stdio.h>
#include <stdint.h>
#include <cassert>
#include <cstdio>
#include <cstdint>
#include <list>
#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))

19
libgcobol/constants.cc
View File

@ -27,16 +27,19 @@
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <math.h>
#include <fenv.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <unistd.h>
#include <cctype>
#include <cerrno>
#include <cmath>
#include <cfenv>
#include <cstdio>
#include <cstdlib>
#include <cstring>
#include <ctime>
#include <algorithm>
#include <unordered_map>
#include <vector>

1
libgcobol/ec.h
View File

@ -33,7 +33,6 @@
#define _CBL_EC_H_
#include <set>
#include <assert.h>
#define EC_ALL_E 0xFFFFFF00

3
libgcobol/gcobolio.h
View File

@ -30,7 +30,8 @@
#ifndef GCOBOLIO_H_
#define GCOBOLIO_H_
#include <stdio.h>
#include <cstdio>
#include <map>
#include <unordered_map>
#include <vector>

18
libgcobol/gfileio.cc
View File

@ -27,17 +27,19 @@
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <ctype.h>
#include <ctype.h>
#include <err.h>
#include <errno.h>
#include <fcntl.h>
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <unistd.h>
#include <cctype>
#include <cerrno>
#include <cmath>
#include <cstdio>
#include <cstdlib>
#include <cstring>
#include <ctime>
#include <algorithm>
#include <vector>

19
libgcobol/gmath.cc
View File

@ -27,16 +27,19 @@
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <math.h>
#include <fenv.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <unistd.h>
#include <cctype>
#include <cerrno>
#include <cmath>
#include <cfenv>
#include <cstdio>
#include <cstdlib>
#include <cstring>
#include <ctime>
#include <algorithm>
#include <vector>

26
libgcobol/intrinsic.cc
View File

@ -28,21 +28,21 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
/* Operational note for COBOL intrinsic functions:
/* COBOL intrinsic functions.
*
* In general, the parameters to these functions are cblc_field_t pointers
* along with an offset, size, and for some functions the "allflags", which
* indicate that the variable is a table that was referenced as TABL(ALL)
*/
In general, the parameters to these functions are cblc_field_t pointers
along with an offset, size, and for some functions the "allflags", which
indicate that the variable is a table that was referenced as TABL(ALL)
*/
#include <time.h>
#include <math.h>
#include <algorithm>
#include <cctype>
#include <langinfo.h>
#include <string.h>
#include <cctype>
#include <cmath>
#include <cstring>
#include <ctime>
#include <algorithm>
#include <vector>
#include "config.h"

11
libgcobol/io.cc
View File

@ -31,11 +31,12 @@
#include "config.h"
#include "io.h"
#include "stdio.h"
#include "stdlib.h"
#include <errno.h>
#include <stdbool.h>
#include <stdint.h>
#include <cstdio>
#include <cstdlib>
#include <cerrno>
#include <cstdbool>
#include <cstdint>
/*
* The Cobol runtime support is responsible to set the file status

14
libgcobol/libgcobol.cc
View File

@ -29,7 +29,6 @@
*/
#include <algorithm>
#include <cctype>
#include <cerrno>
#include <cstdio>
#include <cstdlib>
#include <cstring>
@ -45,7 +44,7 @@
#include <err.h>
#include <fcntl.h>
#include <fenv.h>
#include <math.h> // required for fpclassify(3)
#include <math.h> // required for fpclassify(3), not in cmath
#include <setjmp.h>
#include <signal.h>
#include <syslog.h>
@ -11434,17 +11433,6 @@ __gg__clear_exception()
ec_stack.top().clear();
}
// Update the list of compiler-maintained enabled exceptions.
extern "C"
void
__gg__stash_exceptions( size_t nec, cbl_enabled_exception_t *ecs )
{
enabled_ECs = cbl_enabled_exceptions_t(nec, ecs);
if( false && MATCH_DECLARATIVE )
warnx("%s: %zu exceptions enabled", __func__, nec);
}
void
cbl_enabled_exception_t::dump( int i ) const {
warnx("cbl_enabled_exception_t: %2d {%s, %s, %zu}",

7
libgcobol/valconv.cc
View File

@ -29,9 +29,10 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include <cctype>
#include <cstdio>
#include <cstring>
#include <algorithm>
#include <unordered_map>
#include <vector>