Support for JOR files

NEWS

@@ -10,6 +10,13 @@ NEWS - user visible changes				-*- outline -*-
    the error output for format errors (for example invalid indicator column)
    is now limitted to 5 per source file
 
+** Suppport for time profiling of modules, sections, paragraphs, entries
+   and external CALLs. This feature is activated by compiling the modules
+   to be profiled with -fprof, and then executing the code with environment
+   variable COB_PROF_ENABLE. The output is stored in a CSV file. Further
+   customization can be done using COB_PROF_FILE, COB_PROF_MAX_DEPTH and
+   COB_PROF_FORMAT
+
   more work in progress
 
 * Important Bugfixes
@@ -39,6 +46,12 @@ NEWS - user visible changes				-*- outline -*-
 	INSPECT CONVERTING (and "simple" INSPECT REPLACING), in general
 	   and especially if both from and to are constants
 
+* Changes in the COBOL runtime
+
+** more substitutions in environment variables: $f for executable filename,
+   $b for executable basename, $d for date in YYYYMMDD format, $t for time
+   in HHMMSS format (before, only $$ was available for pid)
+
 * Known issues in 3.x
 
 ** testsuite:

bin/Makefile.am

@@ -20,8 +20,9 @@
 # along with GnuCOBOL.  If not, see <https://www.gnu.org/licenses/>.
 
 bin_SCRIPTS = cob-config
-bin_PROGRAMS = cobcrun
+bin_PROGRAMS = cobcrun jorread
 cobcrun_SOURCES = cobcrun.c
+jorread_SOURCES = jorread.c
 dist_man_MANS = cobcrun.1 cob-config.1
 COBCRUN = cobcrun$(EXEEXT)
 
@@ -31,6 +32,9 @@ AM_CFLAGS = $(CODE_COVERAGE_CFLAGS)
 cobcrun_LDADD = $(top_builddir)/libcob/libcob.la \
 	$(top_builddir)/lib/libsupport.la \
 	$(PROGRAMS_LIBS) $(CODE_COVERAGE_LIBS)
+jorread_LDADD = $(top_builddir)/libcob/libcob.la \
+	$(top_builddir)/lib/libsupport.la \
+	$(PROGRAMS_LIBS) $(CODE_COVERAGE_LIBS)
 
 # Add rules for code-coverage testing, as provided AX_CODE_COVERAGE
 include $(top_srcdir)/aminclude_static.am

bin/jorread.c

@@ -0,0 +1,254 @@
+/*
+   Copyright (C) 2024 Free Software Foundation, Inc.
+   Written by Fabrice LE FESSANT
+
+   This file is part of GnuCOBOL.
+
+   The GnuCOBOL module loader is free software: you can redistribute it
+   and/or modify it under the terms of the GNU General Public License
+   as published by the Free Software Foundation, either version 3 of the
+   License, or (at your option) any later version.
+
+   GnuCOBOL is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with GnuCOBOL.  If not, see <https://www.gnu.org/licenses/>.
+*/
+
+#include "tarstamp.h"
+#include "config.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+
+#ifdef	HAVE_LOCALE_H
+#include <locale.h>
+#endif
+#ifdef	HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#include <arpa/inet.h>
+
+#include "../libcob/common.h"
+#include "../libcob/cobgetopt.h"
+
+#define GET_U16(addr)				\
+	(*((cob_u16_t*) (addr)))
+
+#define GET_U32(addr)				\
+	(*((cob_u32_t*) (addr)))
+
+#define GET_S16(addr)				\
+	( *((cob_s16_t*) (addr)))
+
+#define GET_S32(addr)				\
+	(*((cob_s32_t*) (addr)))
+
+
+#define MAX_LEVELS 10
+
+static void jor_read (char *filename)
+{
+	FILE *fd = fopen (filename, "r");
+	char *buffer;
+	char header[JOR_HEADER_SIZE];
+	int len;
+	int version;
+	int size;
+	char *fields[256];
+	char *position;
+	int current_level;
+	char spaces[3+2*MAX_LEVELS];
+	int first_field[MAX_LEVELS];
+
+	memset (spaces, ' ', sizeof(spaces));
+	if ( !fd ){
+		fprintf (stderr, "Error: could not open file %s\n", filename);
+		exit (2);
+
+	}
+
+	len = fread (header, 1, JOR_HEADER_SIZE, fd);
+
+	if ( len<JOR_HEADER_SIZE ){
+		fprintf (stderr, "Error: truncated file %s\n", filename);
+		exit (2);
+
+	}
+	if ( memcmp (header, JOR_MAGIC, JOR_MAGIC_LEN) ){
+		fclose (fd);
+		fprintf (stderr, "Error: file %s is not a GnuCOBOL JOR file\n",
+			 filename);
+		exit (2);
+	}
+
+	size = GET_U32(header+JOR_MAGIC_LEN);
+	version = header[JOR_MAGIC_LEN+4];
+
+	if (size < JOR_HEADER_SIZE){
+		fprintf (stderr, "Error: corrupted file %s (wrong size %d)\n",
+			 filename, size);
+		exit (2);
+	}
+
+	size -= JOR_HEADER_SIZE;
+
+	if (version>1){
+		fprintf (stderr, "Error: file %s version %d too high\n",
+			 filename, version);
+		exit (2);
+	}
+
+	buffer = cob_malloc (size);
+
+	len = fread (buffer, 1, size, fd);
+
+	if (len < size){
+		fprintf (stderr, "Warning: corrupted file %s, size %d < expected %d\n",
+			 filename, len, size);
+	}
+
+	fprintf (stderr, "Reading file %s with content size %d\n",
+		 filename, size);
+	position = buffer;
+	current_level = 0;
+
+	printf ("{\n");
+	first_field[0] = 1;
+
+	while (position - buffer < size){
+		int record_size = GET_U16 (position);
+		char *next_position = position+record_size;
+		int opcode = position[2];
+
+		switch (opcode){
+		case OPCODE_NEW_NAME: {
+			// fprintf (stderr, "opcode OPCODE_NEW_NAME\n");
+			int id = position[3];
+			int slen = position[4];
+			char *s = cob_malloc(slen+1);
+
+			memcpy (s, position+5, slen);
+			s[slen] = 0;
+			fields[id] = s;
+
+			// fprintf (stderr, "Field %d is '%s'\n", id, s);
+			break;
+		}
+		case OPCODE_LOCAL_FIELD: {
+			// fprintf (stderr, "opcode OPCODE_LOCAL_FIELD\n");
+			int level = position[3];
+			int id = position[4];
+			int type = position[5];
+
+			while (level < current_level){
+				spaces[current_level*2] = 0;
+				printf ("%s}", spaces);
+				spaces[current_level*2] = ' ';
+				current_level--;
+			}
+
+			if (!first_field[current_level]){
+				printf (",\n");
+			} else {
+				first_field[current_level] = 0;
+			}
+
+			spaces[2+current_level*2] = 0;
+			printf ("%s\"%s\" : ", spaces, fields[id]);
+			spaces[2+current_level*2] = ' ';
+
+			switch (type){
+			case TYPE_RECORD:
+				printf ("{\n");
+				current_level = level+1;
+				first_field[current_level] = 1;
+				break;
+			case TYPE_UINT8: {
+				cob_u8_t value = position[6];
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_INT8: {
+				int value = position[6];
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_UINT16: {
+				cob_u16_t value = GET_U16 (position+6);
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_INT16: {
+				cob_s16_t value = GET_S16 (position+6);
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_UINT32: {
+				cob_u32_t value = GET_U32 (position+6);
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_INT32: {
+				cob_s32_t value = GET_S32 (position+6);
+				printf ("%d", value);
+				break;
+			}
+			case TYPE_FLOAT: {
+				double value = ((double*) (position+6))[0];
+				printf ("%f", value);
+				break;
+			}
+			case TYPE_STRING16: {
+				exit (2);
+			}
+			case TYPE_STRING8: {
+				int len = position[6];
+				char buf[256];
+
+				memcpy (buf, position+7, len);
+				buf[len]=0;
+				printf ("\"%s\"", buf);
+				break;
+			}
+			}
+			break;
+		}
+		default:
+			fprintf (stderr, "Error: file %s contains an unknown opcode %d",
+				 filename, opcode);
+		}
+
+		position = next_position ;
+		// fprintf (stderr, "record_size = %d\n", record_size);
+	}
+
+	while (0 < current_level){
+		spaces[current_level*2] = 0;
+		printf ("%s}\n", spaces);
+		spaces[current_level*2] = ' ';
+		current_level--;
+	}
+
+	printf ("}\n");
+
+	fprintf (stderr, "done\n");
+	fclose (fd);
+}
+
+int main (int argc, char** argv)
+{
+
+	int i;
+
+	for (i=1; i<argc; i++){
+		jor_read (argv[i]);
+	}
+	return 0;
+}

cobc/ChangeLog

@@ -1,3 +1,11 @@
+2023-09-04  Fabrice Le Fessant <[email protected]> and Emilien Lemaire <[email protected]>
+
+	* parser.y: generate calls to "cob_prof_function_call" in the
+	  parsetree when profiling is unabled, when entering/leaving
+	  profiled blocks
+	* flag.def: add `-fprof` to enable profiling
+	* codegen.c: handle profiling code generation under the
+	  cb_flag_prof guard
 
 2023-11-29  Fabrice Le Fessant <[email protected]>