From 5612b015920f08249f792b4e40f8f3c92be70b12 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Thu, 21 Dec 2023 16:37:05 -0500
Subject: [PATCH] LOCALE-COMPARE, -DATE, -TIME, and -TIME-FROM-SECONDS
---
gcc/cobol/parse.y | 18 +++--
libgcobol/intrinsic.cc | 147 ++++++++++++++++++++++++++++++++++++++++-
2 files changed, 157 insertions(+), 8 deletions(-)
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 4c142c3362c4..f07024250e9f 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -8851,7 +8851,8 @@ intrinsic_locale:
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
- if( ! intrinsic_call_2($$, LOCALE_COMPARE, $r1, $r2) ) YYERROR;
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR;
}
| LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
{
@@ -8864,9 +8865,10 @@ intrinsic_locale:
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
- if( ! intrinsic_call_1($$, LOCALE_DATE, $r1) ) YYERROR;
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR;
}
- | LOCALE_DATE '(' varg[r1] varg[r2] ')'
+ | LOCALE_DATE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
@@ -8876,9 +8878,10 @@ intrinsic_locale:
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
- if( ! intrinsic_call_1($$, LOCALE_TIME, $r1) ) YYERROR;
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR;
}
- | LOCALE_TIME '(' varg[r1] varg[r2] ')'
+ | LOCALE_TIME '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
@@ -8888,9 +8891,10 @@ intrinsic_locale:
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
- if( ! intrinsic_call_1($$, LOCALE_TIME_FROM_SECONDS, $r1) ) YYERROR;
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR;
}
- | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')'
+ | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
index d8ca2eed95cc..744fce55517d 100644
--- a/libgcobol/intrinsic.cc
+++ b/libgcobol/intrinsic.cc
@@ -42,6 +42,8 @@
#include <math.h>
#include <algorithm>
#include <cctype>
+#include <langinfo.h>
+
#include "libgcobol.h"
#include "intrinsic.h"
@@ -4874,7 +4876,150 @@ void __gg__substitute(cblc_field_t *dest,
__gg__adjust_dest_size(dest, outdex);
memcpy(dest->data, retval, outdex);
-
free(pflasts);
free(retval);
}
+
+extern "C"
+void
+__gg__locale_compare( cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg2,
+ cblc_refer_t *arg_locale)
+ {
+ char achretval[2] = "?";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ achretval[0] = '=';
+ size_t length = std::min(arg1->qual_size, arg2->qual_size);
+ for(size_t i=0; i<length; i++ )
+ {
+ if( arg1->qual_data[i] < arg2->qual_data[i] )
+ {
+ achretval[0] = '<';
+ break;
+ }
+ if( arg1->qual_data[i] > arg2->qual_data[i] )
+ {
+ achretval[0] = '>';
+ break;
+ }
+ }
+ if( achretval[0] == '=' )
+ {
+ if( arg1->qual_size < arg2->qual_size )
+ {
+ achretval[0] = '<';
+ }
+ else if( arg1->qual_size > arg2->qual_size )
+ {
+ achretval[0] = '>';
+ }
+ }
+ }
+
+ __gg__adjust_dest_size(dest, 1);
+ ascii_to_internal_str(achretval, 1);
+ dest->data[0] = *achretval;
+ }
+
+extern "C"
+void
+__gg__locale_date(cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm;
+ memcpy(ach, arg1->qual_data, 8);
+ ach[8] = '\0';
+ long ymd = atoi(ach);
+ tm.tm_year = ymd/10000 - 1900;
+ tm.tm_mon = ymd/100 % 100;
+ tm.tm_mday = ymd % 100;
+ strcpy(ach, nl_langinfo(D_FMT));
+ strftime(ach, sizeof(ach), nl_langinfo(D_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
+
+extern "C"
+void
+__gg__locale_time(cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm = {};
+ memcpy(ach, arg1->qual_data, 8);
+ ach[8] = '\0';
+ long hms = atoi(ach);
+ tm.tm_hour = hms/10000;
+ tm.tm_min = hms/100 % 100;
+ tm.tm_sec = hms % 100;
+ strftime(ach, sizeof(ach), nl_langinfo(T_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
+
+extern "C"
+void
+__gg__locale_time_from_seconds( cblc_field_t *dest,
+ cblc_refer_t *arg1,
+ cblc_refer_t *arg_locale)
+ {
+ char ach[256] = " ";
+
+ if( arg_locale && arg_locale->field )
+ {
+ // We don't yet know what to do with a locale
+ exception_raise(ec_locale_missing_e);
+ }
+ else
+ {
+ // Default locale
+ tm tm = {};
+
+ int rdigits;
+ long seconds = (long)__gg__binary_value_from_refer(&rdigits, arg1);
+ tm.tm_hour = seconds/3600;
+ tm.tm_min = ((seconds%3600) / 60) % 100;
+ tm.tm_sec = seconds % 100;
+ strftime(ach, sizeof(ach), nl_langinfo(T_FMT), &tm);
+ }
+
+ __gg__adjust_dest_size(dest, strlen(ach));
+ ascii_to_internal_str(ach, strlen(ach));
+ memcpy(dest->data, ach, strlen(ach));
+ }
--
GitLab