Skip to content

Commit cf2f293

Browse files
n-isakan-isaka
committed
Merge pull request #22 from opensourcecobol/addFuncCALLEDBY
商用COBOLに存在するC$CALLEDBYルーチンを実装しました。
2 parents 38331ec + f5c6af1 commit cf2f293

9 files changed

Lines changed: 101 additions & 5 deletions

File tree

‎cobc/codegen.c‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4109,12 +4109,12 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
41094109

41104110
/* Note spare byte at end */
41114111
if (prog->currency_symbol != '\\') {
4112-
output (", %d, '%c', '%c', '%c', %d, %d, %d, 0 };\n",
4112+
output (", %d, '%c', '%c', '%c', %d, %d, %d, 0, NULL };\n",
41134113
cb_display_sign, prog->decimal_point, prog->currency_symbol,
41144114
prog->numeric_separator, cb_filename_mapping, cb_binary_truncate,
41154115
cb_pretty_display);
41164116
} else {
4117-
output (", %d, '%c', '\\%c', '%c', %d, %d, %d, 0 };\n",
4117+
output (", %d, '%c', '\\%c', '%c', %d, %d, %d, 0, NULL };\n",
41184118
cb_display_sign, prog->decimal_point, prog->currency_symbol,
41194119
prog->numeric_separator, cb_filename_mapping, cb_binary_truncate,
41204120
cb_pretty_display);
@@ -4360,6 +4360,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
43604360
prog->program_id);
43614361
}
43624362
}
4363+
output_line ("cob_set_programid (&module, \"%s\");", prog->program_id);
43634364
if (prog->decimal_index_max) {
43644365
output_line ("/* Initialize decimal numbers */");
43654366
for (i = 0; i < prog->decimal_index_max; i++) {

‎libcob/common.c‎

Lines changed: 41 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2658,8 +2658,48 @@ cob_acuw_justify (unsigned char *data, ...)
26582658
return 0;
26592659
}
26602660

2661-
char *
2661+
void
2662+
cob_set_programid (struct cob_module *module, const char *program_name)
2663+
{
2664+
int length;
2665+
length = strlen (program_name);
2666+
if (module->program_id != NULL) {
2667+
free (module->program_id);
2668+
}
2669+
module->program_id = cob_malloc ((const size_t) length+1);
2670+
strcpy (module->program_id, program_name);
2671+
}
26622672

2673+
int
2674+
cob_acuw_calledby (unsigned char *data)
2675+
{
2676+
int length;
2677+
cob_field *f1;
2678+
char *called_program_name;
2679+
2680+
COB_CHK_PARMS (C$CALLEDBY, 1);
2681+
2682+
if (cob_current_module->cob_procedure_parameters[0]) {
2683+
f1 = cob_current_module->cob_procedure_parameters[0];
2684+
if (cob_current_module->next == NULL) {
2685+
memset (f1->data, ' ', (int)f1->size);
2686+
return 0;
2687+
} else {
2688+
called_program_name = (const char *)cob_current_module->next->program_id;
2689+
if (called_program_name == NULL) {
2690+
return -1;
2691+
}
2692+
length = (int)f1->size;
2693+
if (strlen (called_program_name) < length) {
2694+
length = strlen (called_program_name);
2695+
}
2696+
memcpy (f1->data, called_program_name, length);
2697+
}
2698+
}
2699+
return 1;
2700+
}
2701+
2702+
char *
26632703
cb_get_jisword_buff (const char *name, char *jbuf, size_t n)
26642704
{
26652705
size_t siz;

‎libcob/common.h‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -351,6 +351,7 @@ struct cob_module {
351351
const unsigned char flag_binary_truncate;
352352
const unsigned char flag_pretty_display;
353353
const unsigned char spare8;
354+
char *program_id;
354355
};
355356

356357
/*******************************/
@@ -447,6 +448,7 @@ COB_EXPIMP int cob_return_args (unsigned char *);
447448
COB_EXPIMP int cob_parameter_size (unsigned char *);
448449
COB_EXPIMP int cob_acuw_sleep (unsigned char *);
449450
COB_EXPIMP int cob_acuw_justify (unsigned char *, ...);
451+
COB_EXPIMP int cob_acuw_calledby (unsigned char *);
450452

451453
/* Utilities */
452454

@@ -459,6 +461,9 @@ COB_EXPIMP void cob_set_location (const char *, const char *,
459461
COB_EXPIMP void cob_ready_trace (void);
460462
COB_EXPIMP void cob_reset_trace (void);
461463

464+
COB_EXPIMP void cob_set_programid (struct cob_module *,
465+
const char *);
466+
462467
/* Switch */
463468

464469
COB_EXPIMP int cob_get_switch (const int);

‎libcob/system.def‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ COB_SYSTEM_GEN ("C$DELETE", 2, cob_acuw_file_delete)
5757
COB_SYSTEM_GEN ("C$FILEINFO", 2, cob_acuw_file_info)
5858
COB_SYSTEM_GEN ("C$GETPID", 0, cob_acuw_getpid)
5959
COB_SYSTEM_GEN ("C$JUSTIFY", 1, cob_acuw_justify)
60+
COB_SYSTEM_GEN ("C$CALLEDBY", 1, cob_acuw_calledby)
6061
COB_SYSTEM_GEN ("C$MAKEDIR", 1, cob_acuw_mkdir)
6162
COB_SYSTEM_GEN ("C$NARG", 1, cob_return_args)
6263
COB_SYSTEM_GEN ("C$SLEEP", 1, cob_acuw_sleep)

‎tests/Makefile.am‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,8 @@ jp_compat_DEPENDENCIES = \
133133
jp-compat.src/io-control.at \
134134
jp-compat.src/greater-less-than-equal.at \
135135
jp-compat.src/file-desc.at \
136-
jp-compat.src/abort-on-file-error.at
136+
jp-compat.src/abort-on-file-error.at \
137+
jp-compat.src/system-routine.at
137138

138139
EXTRA_DIST = $(srcdir)/package.m4 $(TESTS) \
139140
$(syntax_DEPENDENCIES) \

‎tests/Makefile.in‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -328,7 +328,8 @@ jp_compat_DEPENDENCIES = \
328328
jp-compat.src/io-control.at \
329329
jp-compat.src/greater-less-than-equal.at \
330330
jp-compat.src/file-desc.at \
331-
jp-compat.src/abort-on-file-error.at
331+
jp-compat.src/abort-on-file-error.at \
332+
jp-compat.src/system-routine.at
332333

333334
EXTRA_DIST = $(srcdir)/package.m4 $(TESTS) \
334335
$(syntax_DEPENDENCIES) \

‎tests/jp-compat‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -418,6 +418,7 @@ at_help_all='1;split-keys.at:1;SPLIT KEYS (ALTERNATE KEY);;
418418
107;abort-on-file-error.at:35;Abort option (fatal) on non-fatal f-status;;
419419
108;abort-on-file-error.at:69;Abort option (default) on fatal f-status;;
420420
109;abort-on-file-error.at:100;Abort option (fatal) on fatal file status;;
421+
110;system-routine.at:1;CALL C$CALLEDBY;;
421422
'
422423

423424
at_keywords=

‎tests/jp-compat.at‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,3 +49,4 @@ m4_include([io-control.at])
4949
m4_include([greater-less-than-equal.at])
5050
m4_include([file-desc.at])
5151
m4_include([abort-on-file-error.at])
52+
m4_include([system-routine.at])

‎tests/jp-compat.src/system-routine.at‎

Lines changed: 45 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,45 @@
1+
AT_SETUP([CALL C$CALLEDBY])
2+
3+
AT_DATA([callee.cob], [
4+
IDENTIFICATION DIVISION.
5+
PROGRAM-ID. callee.
6+
DATA DIVISION.
7+
WORKING-STORAGE SECTION.
8+
01 PROG-NAME PIC X(30).
9+
01 RET-CODE PIC 9.
10+
PROCEDURE DIVISION.
11+
CALL "C$CALLEDBY" USING PROG-NAME
12+
GIVING RET-CODE
13+
END-CALL.
14+
DISPLAY PROG-NAME RET-CODE
15+
END-DISPLAY.
16+
EXIT PROGRAM.
17+
])
18+
19+
AT_DATA([caller.cob], [
20+
IDENTIFICATION DIVISION.
21+
PROGRAM-ID. caller.
22+
DATA DIVISION.
23+
WORKING-STORAGE SECTION.
24+
01 PROG-NAME PIC X(30).
25+
01 RET-CODE PIC 9.
26+
PROCEDURE DIVISION.
27+
CALL "callee"
28+
END-CALL.
29+
CALL "C$CALLEDBY" USING PROG-NAME
30+
GIVING RET-CODE
31+
END-CALL.
32+
DISPLAY PROG-NAME RET-CODE
33+
END-DISPLAY.
34+
STOP RUN.
35+
])
36+
37+
AT_CHECK([${COMPILE} caller.cob])
38+
AT_CHECK([${COMPILE_MODULE} callee.cob])
39+
AT_CHECK([./caller], [0],
40+
[caller 1
41+
0
42+
])
43+
44+
AT_CLEANUP
45+

0 commit comments

Comments
 (0)