From 526587d39a004422af16a990044d8b3acfb1965e Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Tue, 18 Oct 2022 21:31:55 -0400
Subject: [PATCH] First successful compilation and creation of
libgcobol.so.4.0.0
---
Makefile.def | 3 +-
gcc/cobol/configurations | 2 +
libgcobol/ChangeLog | 3617 -----------
libgcobol/Makefile.in | 169 +-
libgcobol/NXConstStr.m | 41 -
libgcobol/Object.m | 41 -
libgcobol/Protocol.m | 34 -
libgcobol/THREADS | 339 -
libgcobol/accessors.m | 289 -
libgcobol/charmaps.cc | 777 +++
libgcobol/class.c | 1007 ---
libgcobol/configure | 6 +-
libgcobol/configure.ac | 1 -
libgcobol/encoding.c | 1267 ----
libgcobol/error.c | 42 -
libgcobol/exception.c | 537 --
libgcobol/gc.c | 459 --
libgcobol/gfileio.cc | 2427 ++++++++
libgcobol/gmath.cc | 773 +++
libgcobol/hash.c | 294 -
libgcobol/init.c | 1043 ----
libgcobol/intrinsic.cc | 838 +++
libgcobol/io.cc | 89 +
libgcobol/ivars.c | 376 --
libgcobol/libgcobol.cc | 8180 +++++++++++++++++++++++++
libgcobol/libobjc.def | 100 -
libgcobol/linking.m | 36 -
libgcobol/memory.c | 134 -
libgcobol/methods.c | 177 -
libgcobol/nil_method.c | 55 -
libgcobol/objc-foreach.c | 51 -
libgcobol/objc-private/README | 4 -
libgcobol/objc-private/accessors.h | 32 -
libgcobol/objc-private/common.h | 44 -
libgcobol/objc-private/error.h | 38 -
libgcobol/objc-private/hash.h | 201 -
libgcobol/objc-private/module-abi-8.h | 307 -
libgcobol/objc-private/objc-list.h | 94 -
libgcobol/objc-private/objc-sync.h | 33 -
libgcobol/objc-private/protocols.h | 38 -
libgcobol/objc-private/runtime.h | 76 -
libgcobol/objc-private/sarray.h | 243 -
libgcobol/objc-private/selector.h | 75 -
libgcobol/objc-sync.c | 459 --
libgcobol/objc/NXConstStr.h | 51 -
libgcobol/objc/Object.h | 62 -
libgcobol/objc/Protocol.h | 54 -
libgcobol/objc/README | 2 -
libgcobol/objc/message.h | 119 -
libgcobol/objc/objc-decls.h | 46 -
libgcobol/objc/objc-exception.h | 109 -
libgcobol/objc/objc-sync.h | 69 -
libgcobol/objc/objc.h | 151 -
libgcobol/objc/runtime.h | 1143 ----
libgcobol/objc/thr.h | 116 -
libgcobol/objects.c | 118 -
libgcobol/protocols.c | 557 --
libgcobol/sarray.c | 523 --
libgcobol/selector.c | 640 --
libgcobol/sendmsg.c | 1164 ----
libgcobol/thr.c | 543 --
61 files changed, 13120 insertions(+), 17195 deletions(-)
delete mode 100644 libgcobol/ChangeLog
delete mode 100644 libgcobol/NXConstStr.m
delete mode 100644 libgcobol/Object.m
delete mode 100644 libgcobol/Protocol.m
delete mode 100644 libgcobol/THREADS
delete mode 100644 libgcobol/accessors.m
create mode 100644 libgcobol/charmaps.cc
delete mode 100644 libgcobol/class.c
delete mode 100644 libgcobol/encoding.c
delete mode 100644 libgcobol/error.c
delete mode 100644 libgcobol/exception.c
delete mode 100644 libgcobol/gc.c
create mode 100644 libgcobol/gfileio.cc
create mode 100644 libgcobol/gmath.cc
delete mode 100644 libgcobol/hash.c
delete mode 100644 libgcobol/init.c
create mode 100644 libgcobol/intrinsic.cc
create mode 100644 libgcobol/io.cc
delete mode 100644 libgcobol/ivars.c
create mode 100644 libgcobol/libgcobol.cc
delete mode 100644 libgcobol/libobjc.def
delete mode 100644 libgcobol/linking.m
delete mode 100644 libgcobol/memory.c
delete mode 100644 libgcobol/methods.c
delete mode 100644 libgcobol/nil_method.c
delete mode 100644 libgcobol/objc-foreach.c
delete mode 100644 libgcobol/objc-private/README
delete mode 100644 libgcobol/objc-private/accessors.h
delete mode 100644 libgcobol/objc-private/common.h
delete mode 100644 libgcobol/objc-private/error.h
delete mode 100644 libgcobol/objc-private/hash.h
delete mode 100644 libgcobol/objc-private/module-abi-8.h
delete mode 100644 libgcobol/objc-private/objc-list.h
delete mode 100644 libgcobol/objc-private/objc-sync.h
delete mode 100644 libgcobol/objc-private/protocols.h
delete mode 100644 libgcobol/objc-private/runtime.h
delete mode 100644 libgcobol/objc-private/sarray.h
delete mode 100644 libgcobol/objc-private/selector.h
delete mode 100644 libgcobol/objc-sync.c
delete mode 100644 libgcobol/objc/NXConstStr.h
delete mode 100644 libgcobol/objc/Object.h
delete mode 100644 libgcobol/objc/Protocol.h
delete mode 100644 libgcobol/objc/README
delete mode 100644 libgcobol/objc/message.h
delete mode 100644 libgcobol/objc/objc-decls.h
delete mode 100644 libgcobol/objc/objc-exception.h
delete mode 100644 libgcobol/objc/objc-sync.h
delete mode 100644 libgcobol/objc/objc.h
delete mode 100644 libgcobol/objc/runtime.h
delete mode 100644 libgcobol/objc/thr.h
delete mode 100644 libgcobol/objects.c
delete mode 100644 libgcobol/protocols.c
delete mode 100644 libgcobol/sarray.c
delete mode 100644 libgcobol/selector.c
delete mode 100644 libgcobol/sendmsg.c
delete mode 100644 libgcobol/thr.c
diff --git a/Makefile.def b/Makefile.def
index e12e4d0fb2e6..47e57db8db46 100644
--- a/Makefile.def
+++ b/Makefile.def
@@ -637,6 +637,8 @@ dependencies = { module=configure-target-libvtv; on=all-target-libstdc++-v3; };
dependencies = { module=all-target-libstdc++-v3; on=configure-target-libgomp; };
dependencies = { module=all-target-liboffloadmic; on=all-target-libgomp; };
+dependencies = { module=all-target-libgcobol; on=install-target-libstdc++-v3; };
+
dependencies = { module=install-target-libgo; on=install-target-libatomic; };
dependencies = { module=install-target-libgfortran; on=install-target-libquadmath; };
dependencies = { module=install-target-libgfortran; on=install-target-libgcc; };
@@ -649,7 +651,6 @@ dependencies = { module=install-target-liboffloadmic; on=install-target-libstdc+
dependencies = { module=install-target-liboffloadmic; on=install-target-libgcc; };
dependencies = { module=install-target-libitm; on=install-target-libgcc; };
dependencies = { module=install-target-libobjc; on=install-target-libgcc; };
-dependencies = { module=install-target-libgcobol; on=install-target-libstdc++-v3; };
dependencies = { module=install-target-libstdc++-v3; on=install-target-libgcc; };
// Target modules in the 'src' repository.
diff --git a/gcc/cobol/configurations b/gcc/cobol/configurations
index 9b34ce324542..13679062a597 100644
--- a/gcc/cobol/configurations
+++ b/gcc/cobol/configurations
@@ -43,6 +43,7 @@ LIBCXXFLAGS_FOR_TARGET="-ggdb -O0" \
--with-pkgversion='debuggable gcc with COBOL front end' \
--disable-bootstrap \
--enable-checking \
+--disable-multilib \
--enable-languages=c,c++,cobol
# For release:
@@ -53,6 +54,7 @@ LIBCXXFLAGS_FOR_TARGET="-ggdb -O0" \
--build=$(../config.guess) \
--prefix=/usr/local/gcobol \
--disable-bootstrap \
+--disable-multilib \
--enable-languages=c,c++,cobol
# convert gcc-cobol/configure.ac to configure by running
diff --git a/libgcobol/ChangeLog b/libgcobol/ChangeLog
deleted file mode 100644
index 1afd92cf49d4..000000000000
--- a/libgcobol/ChangeLog
+++ /dev/null
@@ -1,3617 +0,0 @@
-2022-08-25 Martin Liska <mliska@suse.cz>
-
- * configure: Regenerate.
-
-2021-01-05 Samuel Thibault <samuel.thibault@ens-lyon.org>
-
- * configure: Re-generate.
-
-2020-12-05 Iain Sandoe <iain@sandoe.co.uk>
-
- PR target/97865
- * configure: Regenerate.
-
-2020-11-29 John David Anglin <danglin@gcc.gnu.org>
-
- * configure: Regenerate.
-
-2020-10-11 Iain Sandoe <iain@sandoe.co.uk>
-
- * encoding.c (_darwin_rs6000_special_round_type_align):
- Use DFMode in the emulation of the special round type.
-
-2020-05-29 H.J. Lu <hjl.tools@gmail.com>
-
- PR bootstrap/95413
- * configure: Regenerated.
-
-2020-05-15 H.J. Lu <hongjiu.lu@intel.com>
-
- PR bootstrap/95147
- * configure: Regenerated.
-
-2020-05-14 H.J. Lu <hongjiu.lu@intel.com>
-
- * configure: Regenerated.
-
-2020-02-12 Sandra Loosemore <sandra@codesourcery.com>
-
- PR libstdc++/79193
- PR libstdc++/88999
-
- * configure: Regenerated.
-
-2020-01-24 Maciej W. Rozycki <macro@wdc.com>
-
- * Makefile.in (aclocal_deps): Add `toolexeclibdir.m4'.
- * aclocal.m4: Include `toolexeclibdir.m4'.
- * configure.ac: Handle `--with-toolexeclibdir='.
- * configure: Regenerate.
-
-2020-01-01 Andrew Pinski <pinskia@gmail.com>
-
- PR libobjc/93099
- * objc/objc-decls.h (objc_EXPORT): Define it to
- extern for DLL_EXPORT define case.
-
-2020-01-01 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2019-11-26 Tobias Burnus <tobias@codesourcery.com>
-
- * Makefile.in (aclocal_deps): Fix path to cet.m4.
-
-2019-09-27 Maciej W. Rozycki <macro@wdc.com>
-
- * configure: Regenerate.
-
-2019-04-23 Ramana Radhakrishnan <ramana.radhakrishnan@arm.com>
- Bernd Edlinger <bernd.edlinger@hotmail.de>
- Jakub Jelinek <jakub@redhat.com>
-
- PR target/89093
- * exception.c (PERSONALITY_FUNCTION): Add general-regs-only target
- attribute for ARM.
-
-2019-03-06 Uroš Bizjak <ubizjak@gmail.com>
-
- * encoding.c (DFmode): #undef before #define.
-
-2019-01-09 Sandra Loosemore <sandra@codesourcery.com>
-
- PR other/16615
- * objc/runtime.h: Change "can not" to "cannot".
-
-2019-01-09 Sandra Loosemore <sandra@codesourcery.com>
-
- PR other/16615
-
- * class.c: Mechanically replace "can not" with "cannot".
- * objc/runtime.h: Likewise.
- * sendmsg.c: Likewise.
-
-2019-01-01 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2018-10-31 Joseph Myers <joseph@codesourcery.com>
-
- PR bootstrap/82856
- * configure.ac: Remove AC_PREREQ.
- * aclocal.m4, config.h.in, configure: Regenerate.
-
-2018-04-24 H.J. Lu <hongjiu.lu@intel.com>
-
- * configure: Regenerated.
-
-2018-04-19 Jakub Jelinek <jakub@redhat.com>
-
- * configure: Regenerated.
-
-2018-04-18 David Malcolm <dmalcolm@redhat.com>
-
- PR jit/85384
- * configure: Regenerate.
-
-2018-02-14 Igor Tsimbalist <igor.v.tsimbalist@intel.com>
-
- PR target/84148
- * configure: Regenerate.
-
-2018-01-03 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2017-11-23 Tom de Vries <tom@codesourcery.com>
-
- * class.c (CLASS_TABLE_HASH): Wrap in "do {} while (0)".
-
-2017-11-17 Igor Tsimbalist <igor.v.tsimbalist@intel.com>
-
- * Makefile.in: Regenerate.
- * aclocal.m4: Likeiwse.
- * configure: Likewise.
- * configure.ac: Set CET_FLAGS. Update XCFLAGS.
-
-2017-08-30 Richard Sandiford <richard.sandiford@linaro.org>
- Alan Hayward <alan.hayward@arm.com>
- David Sherwood <david.sherwood@arm.com>
-
- * encoding.c (_darwin_rs6000_special_round_type_align): Prefix mode
- names with E_ in case statements.
-
-2017-02-07 Richard Biener <rguenther@suse.de>
-
- PR tree-optimization/79256
- PR middle-end/79278
- * encoding.c (objc_layout_structure_next_member): Adjust
- ADJUST_FIELD_ALIGN usage.
-
-2017-01-18 Matthias Klose <doko@ubuntu.com>
-
- PR libobjc/78697
- * configure.ac: Allow default for --with-target-bdw-gc-include.
- * configure: Regenerate.
-
- PR libobjc/78698
- * configure.ac: Use the libgc.la file when available.
- * configure: Regenerate.
-
-2017-01-17 Jakub Jelinek <jakub@redhat.com>
-
- PR other/79046
- * configure: Regenerated.
- * configure.ac: Add GCC_BASE_VER.
- * Makefile.in (gcc_version): Use @get_gcc_base_ver@ instead of cat to
- get version from BASE-VER file.
- * configure: Regenerated.
-
-2017-01-01 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2016-12-01 Matthias Klose <doko@ubuntu.com>
-
- * configure.ac: Don't use pkg-config to check for bdw-gc.
- * configure: Regenerate.
-
-2016-11-30 Matthias Klose <doko@ubuntu.com>
-
- * configure.ac: Set BDW_GC_CFLAGS and BDW_GC_LIBS after checking
- for the existence of the pkg-config modules.
- * Regenerate.
-
-2016-11-30 Jakub Jelinek <jakub@redhat.com>
-
- * configure.ac (--enable-objc-gc): If not given, default to
- enable_objc_gc=no.
- * configure: Regenerated.
-
-2016-11-30 Matthias Klose <doko@ubuntu.com>
-
- * configure.ac (--enable-objc-gc): Allow to configure with a
- system provided boehm-gc.
- * configure: Regenerate.
- * Makefile.in (OBJC_BOEHM_GC_LIBS): Get value from configure.
- * gc.c: Include system bdw-gc headers.
- * memory.c: Likewise.
- * objects.c: Likewise.
-
-2016-11-15 Matthias Klose <doko@ubuntu.com>
-
- * aclocal.m4: Regenerate.
- * configure: Likewise.
-
-2016-01-04 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2015-11-07 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- PR libobjc/24775
- * encoding.c (_darwin_rs6000_special_round_type_align): Use
- __CHAR_BIT__ instead of BITS_PER_UNIT.
- (objc_sizeof_type): Likewise.
- (objc_layout_structure): Likewise.
- (objc_layout_structure_next_member): Likewise.
- (objc_layout_finish_structure): Likewise.
- (objc_layout_structure_get_info): Likewise.
-
-2015-11-03 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- PR libobjc/24775
- * encoding.c (objc_layout_finish_structure): Remove usage of
- ROUND_TYPE_SIZE.
-
-2015-09-12 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- PR libobjc/24775
- * sendmsg.c (tm.h): Remove include.
-
-2015-09-12 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- PR libobjc/24775
- * sendmsg.c (gen_rtx): Remove macro.
- (gen_rtx_MEM): Likewise.
- (gen_rtx_REG): Likewise.
- (rtx): Likewise.
-
-2015-09-12 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- PR libobjc/24775
- * sendmsg.c: Remove check of STRUCT_VALUE macro.
-
-2015-05-13 Eric Botcazou <ebotcazou@adacore.com>
-
- * configure.ac: Remove manual SJLJ check.
- * config.h.in: Regenerate.
- * configure: Likewise.
- * exception.c: Replace SJLJ_EXCEPTIONS by __USING_SJLJ_EXCEPTIONS__.
-
-2015-05-13 Michael Haubenwallner <michael.haubenwallner@ssi-schaefer.com>
-
- * aclocal.m4: Regenerated with automake-1.11.6.
-
-2015-05-04 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- * configure: Regenerate.
-
-2015-05-01 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- * acinclude.m4: Include bitfields.m4.
- * config.h.in: Regenerate.
- * configure: Likewise.
- * configure.ac: Invoke gt_BITFIELD_TYPE_MATTERS.
- * encoding.c: Check HAVE_BITFIELD_TYPE_MATTERS.
-
-2015-04-29 Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
-
- * encoding.c (objc_layout_structure_next_member): Check the value of
- PCC_BITFIELD_TYPE_MATTERS not if it is defined.
-
-2015-02-05 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- PR libobjc/63765
- * thr.c (_XOPEN_SOURCE): Remove.
-
-2015-01-27 Matthias Klose <doko@ubuntu.com>
-
- * sendmsg.c: Add prototypes for __objc_get_forward_imp and get_imp.
-
-2015-01-09 Dimitris Papavasiliou <dpapavas@gmail.com>
-
- PR libobjc/51891
- * ivars.c: Add a check for classes without instance
- variables, which have a NULL ivar list pointer.
-
-2015-01-05 Jakub Jelinek <jakub@redhat.com>
-
- Update copyright years.
-
-2014-11-21 H.J. Lu <hongjiu.lu@intel.com>
-
- PR bootstrap/63784
- * configure: Regenerated.
-
-2014-11-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
-
- PR target/63610
- * configure: Regenerate.
-
-2014-11-05 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- * thr.c (_XOPEN_SOURCE): Define as 600.
-
-2014-07-27 Alan Modra <amodra@gmail.com>
- Matthias Klose <doko@ubuntu.com>
-
- PR libobjc/61920
-
- * encoding.c: Define rs6000_special_adjust_field_align_p.
-
-2014-01-02 Richard Sandiford <rdsandiford@googlemail.com>
-
- Update copyright years
-
-2013-09-20 Alan Modra <amodra@gmail.com>
-
- * configure: Regenerate.
-
-2013-07-21 Ondřej BÃÂlka <neleai@seznam.cz>
-
- * class.c: Fix typos.
- * encoding.c: Likewise.
- * init.c: Likewise.
- * objc-private/runtime.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc-sync.c: Likewise.
-
-2013-07-04 Kai Tietz <ktietz@redhat.com>
-
- * exception.c: Add check for SjLj to SEH blocks.
-
-2013-02-03 Richard Sandiford <rdsandiford@googlemail.com>
-
- Update copyright years.
-
-2012-10-19 Michael Meissner <meissner@linux.vnet.ibm.com>
-
- * encoding.c (TARGET_VSX): Provide definitions based on the
- current compilation options, and not based off the target options
- structure.
- (TARGET_ALTIVEC): Likewise.
- (TARGET_64BIT): Likewise.
-
-2012-09-14 David Edelsohn <dje.gcc@gmail.com>
-
- * configure: Regenerated.
-
-2012-07-19 Tristan Gingold <gingold@adacore.com>
- Richard Henderson <rth@redhat.com>
-
- * exception.c (__gnu_objc_personality_seh0): New function.
-
-2012-05-16 H.J. Lu <hongjiu.lu@intel.com>
-
- * configure: Regenerated.
-
-2012-03-12 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- * configure.ac (enable_objc_gc): Remove alpha*-dec-osf* handling.
- * configure: Regenerate.
-
- * thr.c (_XOPEN_SOURCE): Define unconditionally.
-
-2011-11-21 Andreas Tobler <andreast@fgznet.ch>
-
- * configure: Regenerate.
-
-2011-11-02 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- * Makefile.in (INCLUDES): Add -I$(MULTIBUILDTOP)../libgcc.
- * configure.ac (target_thread_file, HAVE_GTHR_DEFAULT): Remove.
- * configure: Regenerate.
- * config.h.in: Regenerate.
-
-2011-10-17 Paul Brook <paul@codesourcery.com>
- Matthias Klose <doko@ubuntu.com>
-
- * exception.c (parse_lsda_header): hardcode ttype_encoding for older
- ARM EABI toolchains.
- (get_ttype_entry) Remove __ARM_EABI_UNWINDER__ variant.
-
-2011-10-09 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/49883
- * init.c (__objc_exec_class): Work around a bug in clang's code
- generation. Clang sets the class->info field to values different
- from 0x1 or 0x2 (the only allowed values in the traditional GNU
- Objective-C runtime ABI) to store some additional information, but
- this breaks backwards compatibility. Wipe out all the bits in the
- fields other than the first two upon loading a class.
-
-2011-10-09 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (objc_lookup_class): Added back for compatibility with
- clang which seems to emit calls to it.
-
-2011-10-08 Richard Frith-Macdonald <rfm@gnu.org>
- Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/50428
- * sendmsg.c (__objc_send_initialize): If a class does not have an
- +initialize method, search for an +initialize method in the
- superclass and in the ancestor classes and execute the first one
- that is found. This makes the GNU runtime behave in the same way
- as the Apple/NeXT runtime with respect to +initialize methods and
- subclassing.
-
-2011-08-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/50002
- * class.c (__objc_update_classes_with_methods): Iterate over meta
- classes as well as normal classes when refreshing the method
- implementations. This fixes replacing class methods.
-
-2011-08-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (class_getSuperclass): Fixed to work with meta classes
- still in construction too.
-
-2011-08-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (class_getSuperclass): Fixed typo in comment.
-
-2011-08-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/49882
- * class.c (class_getSuperclass): Return the superclass if the
- class is in construction.
- * objc/runtime.h (class_getSuperclass): Updated documentation.
-
-2011-08-05 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- * Makefile.in (INCLUDES): Search
- $(srcdir)/$(MULTISRCTOP)../libgcc.
-
-2011-06-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc.h (__GNU_LIBOBJC__): Bumped to 20110608.
-
-2011-06-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * configure.ac (VERSION): Bumped to 4:0:0.
- * configure (VERSION): Likewise.
-
-2011-06-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/README: Updated.
- * objc-private/selector.h: Updated comments.
-
-2011-06-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c (class_get_instance_method): Removed.
- (class_get_class_method): Removed.
- (objc_get_uninstalled_dtable): Removed.
-
-2011-06-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/module-abi-8.h (class_get_instance_size): Removed.
- * objects.c (class_create_instance): Removed.
- * error.c (__USE_FIXED_PROTOTYPES__): Removed.
- * gc.c (__objc_generate_gc_type_description): Use
- class_getInstanceSize() instead of class_get_instance_size().
- * selector.c (sel_types_match): Made static.
- (sel_get_typed_uid): Removed.
- (sel_get_any_typed_uid): Removed.
- (sel_get_name): Removed.
- (sel_get_type): Removed.
- (sel_register_name): Removed.
- (sel_register_typed_name): Removed.
- (sel_get_uid): Removed.
-
-2011-06-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * encoding.c (method_get_number_of_arguments): Removed.
- (method_get_sizeof_arguments): Removed.
-
-2011-06-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (objc_next_class): Removed.
- (class_pose_as): Removed.
- (CLASSOF): Removed.
- (class_table_replace): Removed.
- (objc_lookup_class): Removed.
-
-2011-06-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- Removed the Traditional Objective-C runtime public API.
- * Makefile.in (OBJC_DEPRECATED_H): Variable removed.
- (install-headers): Do not create the objc/deprecated directory and
- do not install the deprecated headers.
- (OBJC_H): Removed encoding.h and objc-api.h.
- * Object.m: Removed all methods with the exception of -class and
- -isEqual:. Updated includes. ([-class]): Use Modern API.
- * objc/Object.h: Do not include deprecated/Object.h.
- * objc/deprecated/Object.h: Removed.
- * linking.m (__objc_linking): Call [Object class] instead of
- [Object name].
- * Protocol.m: Removed all methods with the exception of -isEqual:.
- Updated includes.
- * objc/Protocol.h: Do not include deprecated/Protocol.h.
- * objc/deprecated/Protocol.h: Removed.
- * objc/deprecated/struct_objc_symtab.h: Removed.
- * objc/deprecated/struct_objc_module.h: Removed.
- * objc/deprecated/struct_objc_ivar.h: Removed.
- * objc/deprecated/struct_objc_ivar_list.h: Removed.
- * objc/deprecated/struct_objc_method.h: Removed.
- * objc/deprecated/struct_objc_method_list.h: Removed.
- * objc/deprecated/struct_objc_protocol_list.h: Removed.
- * objc/deprecated/struct_objc_category.h: Removed.
- * objc/deprecated/MetaClass.h: Removed.
- * objc/deprecated/objc_msg_sendv.h: Removed.
- * objc/deprecated/README: Removed.
- * objc/deprecated/struct_objc_class.h: Removed.
- * objc/deprecated/struct_objc_protocol.h: Removed.
- * objc/deprecated/struct_objc_selector.h: Removed.
- * objc/encoding.h: Removed.
- * objc/message.h (struct objc_super): Removed the definition for
- the Traditional Objective-C runtime API.
- * objc/objc.h: Do not include objc/objc-decls.h.
- deprecated/struct_objc_selector.h, deprecated/MetaClass.h,
- deprecated/struct_objc_class.h, deprecated/struct_objc_protocol.h
- and deprecated/objc_msg_sendv.h. Uncommented new definition of
- Protocol *.
- * objc/objc-api.h: Removed.
- * objc/runtime.h: Updated comments. Removed check to detect
- concurrent usage of Traditional and Modern APIs.
- * objc-private/module-abi-8.h: Always define struct objc_class and
- struct objc_protocol. (struct objc_protocol_list): Changed type
- of 'list' argument from 'Protocol *' to 'struct objc_protocol *'.
- (class_get_instance_size): Added.
- * objc-private/protocols.h (__objc_protocols_add_protocol): Take a
- 'struct objc_protocol *' as argument, not a 'Protocol *'.
- * objc-private/runtime.h: Updated comments.
- * objc-private/selector.h (struct objc_selector, sel_eq): Added.
- * class.c: Include objc-private/selector.h.
- (objc_get_meta_class): Return a Class instead of a MetaClass.
- * encoding.c (method_get_next_argument): Removed.
- (method_get_first_argument): Removed.
- (method_get_nth_argument): Removed.
- * gc.c: Include objc/runtime.h instead of objc/encoding.h.
- Include objc-private/module-abi-8.h and ctype.h.
- * protocols.c (__objc_protocols_add_protocol): Take a 'struct
- objc_protocl *' as argument, not a 'Protocol *'.
- (class_addProtocol): Added casts to 'struct objc_protocol *' and
- 'Protocol *'.
- (class_copyProtocolList): Likewise.
- (protocol_conformsToProtocol): Likewise.
- (protocol_copyProtocolList): Likewise.
- * sarray.c: Include objc-private/module-abi-8.h.
- * sendmsg.c (method_get_next_argument): Removed.
- (method_get_first_argument): Removed.
- (method_get_nth_argument): Removed.
- (objc_msg_sendv): Removed.
- (arglist_t, retval_t): New. (class_get_class_method): Take a
- 'Class', not 'MetaClass', argument.
- * thr.c: Include module-abi-8.h.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Removed struct_objc_static_instances.h
- and objc_get_uninstalled_dtable.h.
- * objc/deprecated/struct_objc_static_instances.h: Removed.
- * objc/deprecated/objc_get_uninstalled_dtable.h: Removed.
- * objc/objc-api.h: Do not include deprecated/objc_static_instances.h
- and deprecated/objc_get_uninstalled_dtable.h.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Removed objc_object_alloc.h.
- * objc/deprecated/objc_object_alloc.h: Removed.
- * objc/objc-api.h: Do not include deprecated/objc_object_alloc.h.
- * objects.c (_objc_object_alloc, _objc_object_dispose,
- _objc_object_copy): Removed.
- * libobjc.def (__objc_object_alloc, __objc_object_copy,
- __objc_object_dispose): Removed.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Removed METHOD_NULL.h.
- * objc/objc-api.h: Do not include deprecated/METHOD_NULL.h.
- * objc/deprecated/METHOD_NULL.h: Removed.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Removed objc_valloc.h,
- objc_malloc.h and objc_unexpected_exception.h.
- (exception.lo): Do not use -Wno-deprecated-declarations.
- (exception_gc.lo): Likewise.
- * objc/objc-api.h: Do not include deprecated/objc_valloc.h,
- deprecated/objc_malloc.h and
- deprecated/objc_unexpected_exception.h.
- * objc/deprecated/objc_valloc.h: Removed.
- * objc/deprecated/objc_malloc.h: Removed.
- * objc/deprecated/objc_unexpected_exception.h: Removed.
- * exception.c (_objc_unexpected_exception): Removed.
- (objc_exception_throw): Do not check for
- _objc_unexpected_exception.
- * memory.c (objc_valloc, _objc_malloc, _objc_atomic_malloc,
- _objc_valloc, _objc_realloc, _objc_calloc, _objc_free): Removed.
- * libobjc.def (_objc_unexpected_exception, objc_valloc): Removed.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc.h: Do not include deprecated/STR.h.
- * objc/deprecated/STR.h: Removed.
- * Makefile.in (OBJC_DEPRECATED_H): removed STR.h.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_H): Removed hash.h and sarray.h.
- (OBJC_DEPRECATED_H): Likewise.
- * libobjc.def (objc_hash_new, objc_hash_delete, objc_hash_add,
- objc_hash_remove, objc_hash_next, objc_hash_value_for_key,
- objc_hash_is_key_in_hash, hash_add, hash_delete, hash_new,
- hash_next, hash_remove, hash_value_for_key, hash_is_key_in_hash,
- sarray_at_put, sarray_at_put_safe, sarray_free, sarray_lazy_copy,
- sarray_new, sarray_realloc, sarray_remove_garbage): Removed.
- * objc/sarray.h: Removed.
- * objc/hash.h: Removed.
- * objc/deprecated/sarray.h: Removed.
- * objc/deprecated/hash.h: Removed.
- * objc/Object.h: Do not include objc/deprecated/hash.h
- * Object.m: Include string.h.
- * objc/objc-api.h: Do not include objc/deprecated/hash.h.
- * objc-private/common.h (GNU_LIBOBJC_COMPILING_LIBOBJC_ITSELF):
- Removed.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Object.m ([-forward::]): Removed.
- * objc/deprecated/Object.h ([-forward::]): Removed.
- * sendmsg.c (__objc_forward): Updated comments.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_H): Removed objc-list.h.
- (OBJC_DEPRECATED_H): Removed objc-list.h.
- * objc/objc-list.h: File removed.
- * objc/deprecated/objc-list.h: File removed.
-
-2011-06-03 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_H): Removed typedstream.h.
- (OBJC_DEPRECATED_H): Removed typedstream.h.
- (C_SOURCE_FILES): Removed archive.c.
- (Object.lo): Rule removed.
- (Object_gc.lo): Likewise.
- (archive.lo): Likewise.
- (archive_gc.lo): Likewise.
- * objc/deprecated/Object.h ([+streamVersion:], [-read], [-write],
- [-awake]): Removed.
- Do not include deprecated/typedstream.h.
- * Object.m: Removed the same methods.
- * archive.c: File removed.
- * objc/typedstream.h: File removed.
- * objc/deprecated/typedstream.h: File removed.
- * libobjc.def (__objc_read_nbyte_uint, __objc_read_nbyte_ulong,
- __objc_write_class, __objc_write_object, __objc_write_selector,
- objc_close_typed_stream, objc_end_of_typed_stream,
- objc_flush_typed_stream, objc_get_stream_class_version,
- objc_open_typed_stream, objc_open_typed_stream_for_file,
- objc_read_array, objc_read_char, objc_read_int, objc_read_long,
- objc_read_object, objc_read_selector, objc_read_short,
- objc_read_string, objc_read_type, objc_read_types,
- objc_read_unsigned_char, objc_read_unsigned_int,
- objc_read_unsigned_long, objc_read_unsigned_short,
- objc_write_array, objc_write_char, objc_write_int,
- objc_write_long, objc_write_object, objc_write_object_reference,
- objc_write_root_object, objc_write_selector, objc_write_short,
- objc_write_string, objc_write_string_atomic, objc_write_type,
- objc_write_types, objc_write_unsigned_char,
- objc_write_unsigned_int, objc_write_unsigned_long,
- objc_write_unsigned_short): Removed.
-
-2011-06-02 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Removed objc_error.h.
- * objc/deprecated/objc_error.h: Removed.
- * objc/objc-api.h: Do not include deprecated/objc_error.h.
- * libobjc.def (objc_error, objc_verror): Removed.
- * error.c (_objc_error_handler, objc_error, objc_verror,
- objc_set_error_handler): Removed.
- * Object.m ([-error:], [-perform:], [-perform:with:],
- [-perform:with:with], [-subclassResponsibility:],
- [-notImplemented:], [-shouldNotImplement:], [-doesNotRecognize:]):
- Removed.
- * objc/deprecated/Object.h: Removed the same methods.
- * sendmsg.c (__objc_forward): Do not try to invoke the "error:"
- method after trying to invoke the "doesNotRecognize:" method.
-
-2011-05-26 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c: Reindented part of the file. No non-trivial changes
- in code.
-
-2011-05-26 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c (__objc_install_dtable_for_class): Use objc_getClass,
- not objc_lookup_class.
-
-2011-05-25 Richard Frith-Macdonald <rfm@gnu.org>
- David Ayers <ayers@fsfe.org>
-
- PR libobjc/38307
- * sendmsg.c: Include objc/hash.h.
- (get_implementation): New function, mostly with code from get_imp
- updated to support the new +initialize dispatch table logic.
- (get_imp): Use get_implementation.
- (__objc_responds_to): Updated to support the new +initialize
- dispatch table logic.
- (class_respondsToSelector): Likewise.
- (objc_msg_lookup): Use get_implementation.
- (__objc_init_install_dtable): Removed.
- (__objc_install_methods_in_dtable): Updated arguments.
- (__objc_install_dispatch_table_for_class): Renamed to
- __objc_install_dtable_for_class and updated to support the new
- +initialize dispatch table logic.
- (__objc_update_dispatch_table_for_class): Updated to support the
- new +initialize dispatch table logic.
- (__objc_forward): Call get_implementation instead of get_imp.
- (prepared_dtable_table): New.
- (__objc_prepare_dtable_for_class): New.
- (__objc_prepared_dtable_for_class): New.
- (__objc_get_prepared_imp): New.
- (__objc_install_prepared_dtable_for_class): New.
-
-2011-05-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/48177
- * selector.c (__sel_register_typed_name): Use sel_types_match()
- instead of strcmp() to compare selector types (Suggestion by
- Richard Frith-Macdonald <rfm@gnu.org>).
-
-2011-04-15 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- PR libobjc/32037
- * Makefile.in (OBJC_GCFLAGS): Move ...
- * configure.ac (enable_objc_gc): ... here.
- Add $(libsuffix) to OBJC_BOEHM_GC.
- * configure: Regenerate.
-
-2011-02-28 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * selector.c (sel_getTypedSelector): Return NULL if there are
- multiple selectors with conflicting types.
- * objc/runtime.h (sel_getTypedSelector): Updated documentation.
-
-2011-02-28 Richard Frith-Macdonald <rfm@gnu.org>
-
- PR libobjc/47922
- * gc.c (class_ivar_set_gcinvisible): Use _C_GCINVISIBLE instead of
- a hardcoded "!".
-
-2011-02-13 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure: Regenerate.
-
-2010-12-26 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (create_tree_of_subclasses_inherited_from): Use
- class_superclass_of_class instead of assuming a class is
- unresolved when it could be resolved. Tidied up assignment and
- check.
- (__objc_tree_insert_class): Enhanced DEBUG_PRINTF.
- (objc_tree_insert_class): Tidied up loop; return immediately upon
- inserting a class.
- (__objc_exec_class): Do not set __objc_class_tree_list.
-
-2010-12-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * selector.c (sel_getTypedSelector): Return NULL if given a NULL
- argument.
- (sel_registerTypedName): Same.
- (sel_registerName): Same.
- * objc/runtime.h: Updated documentation.
-
-2010-12-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (class_addIvar): Updated documentation. The
- alignment is actually the log_2 of the alignment in bytes.
- * ivars.c (class_addIvar): Corresponding change to the
- implementation.
-
-2010-12-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (sel_getType): Renamed to sel_getTypeEncoding to
- be consistent with method_getTypeEncoding and
- ivar_getTypeEncoding.
- (sel_copyTypedSelectorList, sel_getTypedSelector): New.
- * selector.c (sel_getType): Renamed to sel_getTypeEncoding.
- (sel_copyTypedSelectorList, sel_getTypedSelector): New.
- (sel_get_type): Updated call to sel_getType.
-
-2010-12-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (class_conformsToProtocol,
- class_copyProtocolList): Updated documentation.
-
-2010-12-23 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (create_tree_of_subclasses_inherited_from): Updated
- DEBUG_PRINTF messages.
- (__objc_tree_insert_class): Same.
- (__objc_send_load_using_method_list): Same.
- (__objc_send_load): Same.
- (__objc_exec_class): Same. In particular, do not print the module
- name since it is no longer used.
- * sendmsg.c (__objc_send_initialize): Added DEBUG_PRINTFs for
- tracking +initialize calls.
- (__objc_update_dispatch_table_for_class): Added DEBUG_PRINTFs for
- tracking updates of dispatch tables.
- (__objc_install_dispatch_table_for_class): Same.
-
-2010-12-23 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
-
- * Makefile.in (libobjc$(libsuffix).la): Link with -Wc,-shared-libgcc.
- (libobjc_gc$(libsuffix).la): Likewise.
-
-2010-12-23 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c (class_addMethod): Return NO if the method already
- exists in the class.
-
-2010-12-22 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (duplicate_classes): New.
- (__objc_exec_class): Initialize duplicate_classes.
- (__objc_create_classes_tree): Ignore classes in the
- duplicate_classes table.
- (__objc_call_load_callback): Same.
- (__objc_init_class): If a duplicate class is found, add it to
- duplicate_classes instead of aborting. Return YES if the class is
- not a duplicate, and NO if it is.
- * objc-private/runtime.h (__objc_init_class): Updated prototype.
-
-2010-12-22 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/objc-list.h: Reindented file. No code changes.
- * objc-private/sarray.h: Same change.
-
-2010-12-22 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/accessors.h: Removed 'extern "C"' guards. This
- file is never compiled with C++.
- * objc-private/hash.h: Same change.
- * objc-private/objc-list.h: Same change.
- * objc-private/objc-sync.h: Same change.
- * objc-private/protocols.h: Same change.
- * objc-private/runtime.h: Same change.
- * objc-private/sarray.h: Same change.
- * objc-private/selector.h: Same change.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/18764
- * class.c (__objc_add_class_to_hash): Return YES if the class was
- added, and NO if it already existed.
- * init.c (__objc_init_class): If __objc_add_class_to_hash returns
- NO, then abort the program with an error message.
- * objc-private/runtime.h (__objc_add_class_to_hash): Updated
- declaration.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (_objc_load_callback): Initialize with 0.
- (__objc_call_callback): Renamed to __objc_call_load_callback.
- Check _objc_load_callback only once, and if it is not set, return
- immediately.
- (objc_send_load): Updated call to __objc_call_callback.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/16110
- * init.c (__objc_send_message_in_list): Renamed to
- __objc_send_load_using_method_list. Do not take an 'op' argument.
- Register the 'load' selector if needed.
- (__objc_send_load): Do not register the 'load' selector. Updated
- call to __objc_send_message_in_list.
- (__objc_create_classes_tree): Add the class of any claimed
- category that was loaded in the module to the list of classes for
- which we try to execute +load.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/common.h: When DEBUG is defined, include <stdio.h>.
- Updated comments.
- * init.c (__objc_tree_insert_class): Use %p, not %x, when printing
- a pointer using DEBUG_PRINTF.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/45953
- * selector.c (__sel_register_typed_name): When registering a new
- selector with the same name as an existing one, reuse the existing
- name string. Also updated types, casts and comments in the whole
- function.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/module-abi-8.h (struct objc_symtab): Declare 'refs'
- to be 'struct objc_selector *' and not 'SEL'.
- * init.c (__objc_exec_class): Call
- __objc_register_selectors_from_module instead of iterating over
- each selector and calling __sel_register_typed_name for each.
- * objc-private/selector.h: Declare
- __objc_register_selectors_from_module instead of
- __sel_register_typed_name.
- * selector.c (__objc_register_selectors_from_module): New.
- (__sel_register_typed_name): Made static.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * linking.m: Do not include objc/NXConstStr.h.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/runtime.h (DEBUG_PRINTF): Moved from here ...
- * objc-private/common.h (DEBUG_PRINTF): To here.
- * hash.c: Do not include objc-private/runtime.h and objc/thr.h.
-
-2010-12-21 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * hash.c: Tidied up comments and indentation. No code changes.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/47012
- * accessors.m (objc_getProperty): If not atomic, do not
- retain/autorelease the returned value.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/runtime.h (__objc_selector_max_index,
- __objc_init_selector_tables, __objc_register_selectors_from_class,
- __objc_register_selectors_from_list,
- __objc_register_selectors_from_description_list): Moved to ...
- * objc-private/selector.h: ... here.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/runtime.h (__objc_class_links_resolved): Removed.
- (__objc_print_dtable_stats): Removed.
- (__sel_register_typed_name): Removed.
- * sendmsg.c (__objc_print_dtable_stats): Use 'void' as argument.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (__objc_exec_class): Call __objc_resolve_class_links (),
- if appropriate, after loading the module.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c (method_setImplementation): Do not declare.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/message.h: Updated comments.
- * objc/runtime.h: Updated comments.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (objc_lookupClass): Renamed to objc_lookUpClass.
- * protocols.c: Updated all calls to objc_lookupClass to call
- objc_lookUpClass instead.
- * sendmsg.c (objc_lookupClass): Do not declare.
- (get_imp): Update call to objc_lookupClass to call
- objc_lookUpClass instead.
- * objc/runtime.h (objc_lookupClass): Renamed to objc_lookUpClass.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (class_ivar_set_gcinvisible): Declare.
- * sendmsg.c (_CLS_IN_CONSTRUCTION, CLS_IS_IN_CONSTRUCTION): Do not
- define. Updated comments.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/encoding.h: Updated comments.
- * objc/runtime.h: Updated comments.
- (objc_setGetUnknownClassHandler): Mark with objc_EXPORT.
- (objc_sizeof_type): Same.
- (objc_alignof_type): Same.
- (objc_aligned_size): Same.
- (objc_promoted_size): Same.
- (objc_skip_type_qualifiers): Same.
- (objc_skip_typespec): Same.
- (objc_skip_offset): Same.
- (objc_skip_argspec): Same.
- (objc_get_type_qualifiers): Same.
- (objc_layout_structure): Same.
- (objc_layout_structure_next_member): Same.
- (objc_layout_finish_structure): Same.
- (objc_layout_structure_get_info): Same.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c: Updated comments.
- * objc/objc-api.h: Updated comments.
- * objc/runtime.h (_objc_load_callback): Declare.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/Object.h: Include deprecated/typedstream.h and
- deprecated/hash.h instead of typedstream.h. Updated comments.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Added objc_msg_sendv.h.
- * objc/deprecated/objc_msg_sendv.h: New.
- * objc/message.h: Do not define retval_t, apply_t, arglist,
- arglist_t, objc_msg_sendv, now in
- objc/deprecated/objc_msg_sendv.h.
- * objc/objc.h: Do not include message.h; include
- objc/deprecated/objc_msg_sendv.h instead. Tidied up comments.
- * sendmsg.c: Include objc/message.h.
- * thr.c: Include objc/message.h.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-exception.h: Include objc-decls.h. Mark all
- functions with objc_EXPORT.
- * objc/objc-sync.h: Same change.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Protocol.m: Moved all methods, with the exception of -isEqual:,
- into the 'Deprecated' category.
- * objc/Protocol.h: Removed all methods, moved to
- objc/deprecated/Protocol.h. Include objc/deprecated/Protocol.h.
- * objc/deprecated/Protocol.h: New.
- * Makefile.in (OBJC_DEPRECATED_H): Added Protocol.h.
-
-2010-12-19 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c: Include objc-private/selector.h. Do not declare
- __sel_register_typed_name.
- * objc-private/selector.h (__sel_register_typed_name): Declare.
- * selector.c: Include objc-private/selector.h.
-
-2010-12-18 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c: Tidied up comments and indentation. No code changes.
- * error.c: Same.
- * exception.c: Same.
- * init.c: Same.
- * ivars.c: Same.
- * memory.c: Same.
- * objc-foreach.c: Same.
- * objc-sync.c: Same.
- * objects.c: Same.
- * protocols.c: Same.
- * sarray.c: Same.
- * thr.c: Same.
-
-2010-12-17 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c: Include objc/runtime.h and objc-private/module-abi-8.h
- instead of objc/objc-api.h.
- (init_check_module_version): Take a 'struct objc_module *'
- argument instead of 'Module_t'. Use 'struct objc_module *'
- instead of 'Module_t'.
- (__objc_created_classes_tree): Take a 'struct objc_module *'
- argument instead of 'Module_t'; use 'struct objc_symtab *' instead
- of 'Symtab_t'.
- (__objc_call_callback): Take a 'struct objc_module *' argument
- instead of 'Module_t'; use 'struct objc_symtab *' instead of
- 'Symtab_t' and 'struct objc_category *' instead of 'Category_t'.
- (_objc_load_callback): Take a 'struct objc_category *' argument
- instead of 'Category *'.
- (class_superclass_of_class): Use objc_getClass() instead of
- objc_lookup_class().
- (create_tree_of_subclasses_inherited_from): Same change (also, use
- an explicit 'if' instead of '?').
- (objc_init_statics): Same change.
- (objc_send_load): Same change.
- (__objc_init_protocol): same change.
- (__objc_send_message_in_list): Take a 'struct objc_method_list *'
- argument instead of 'MethodList_t'. Use 'struct objc_method *'
- instead of 'Method_t'.
- (__objc_send_load): Use 'struct objc_method_list *' instead of
- 'MethodList_t'. Use sel_registerName() instead of
- sel_register_name().
- (__objc_exec_class): Take a 'struct objc_module *' argument
- instead of 'Module_t'. Use 'struct objc_symtab *' instead of
- 'Symtab_t'. Use objc_getClass() instead of objc_lookup_class().
- Use 'struct objc_category *' instead of 'Category_t'.
-
-2010-12-16 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c: Include objc/runtime.h instead of objc/objc-api.h.
- Include objc-private/module-abi-8.h and objc-private/selector.h
- instead of objc/encoding.h.
- (objc_msg_lookup_super): Use super->super_class instead of
- super->class.
- (method_get_first_argument, method_get_next_argument): Declare
- locally.
- (class_get_instance_method): Declare before using.
- (objc_msg_sendv): Use 'struct objc_method' instead of 'Method'.
- (__objc_init_dispatch_tables, __objc_send_initialize): Use
- sel_registerName() instead of sel_register_name().
- (__objc_forward): Use sel_getName() instead of sel_get_name().
- (objc_get_uninstalled_dtable): Use 'void' as argument.
- * objc-private/selector.h: New.
-
-2010-12-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/message.h (objc_super): When using the modern API, do not
- define Super and Super_t, and always use 'super_class' for the
- super class field.
- (objc_msg_lookup_super): Updated prototype to use 'struct
- objc_super *' instead of 'Super_t'.
- * sendmsg.c (objc_msg_lookup_super): Updated prototype to use
- 'struct objc_super *' instead of 'Super_t'.
-
-2010-12-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/message.h: Update comments, reindented code and moved
- deprecated types and functions at the end of the file. No code
- changes.
-
-2010-12-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * ivars.c (class_addIvar): Use the 'size' argument instead of
- trying to calculate it using objc_sizeof_type().
- * objc/runtime.h (class_addIvar): Updated comments.
-
-2010-12-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c: Reindented some code and tidied up comments. No
- actual code changes.
-
-2010-12-14 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/Object.h: Moved all the methods, with the exception of
- -class and -isEqual:, into ...
- * objc/deprecated/Object.h: here.
- * Object.m: Moved all the methods, with the exception of -class
- and -isEqual: into the 'Deprecated' category.
-
-2010-12-14 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objects.c (object_copy): Do not #undef as we are no longer
- including objc/objc-api.h.
- * selector.c: Include objc/runtime.h and
- objc-private/module-abi-8.h. Do not include objc/objc-api.h and
- objc/encoding.h. Updated
- (__objc_register_selectors_from_class): Use struct
- objc_method_list * instead of MethodList_t.
- (__objc_register_selectors_from_list): Use Method instead of
- Method_t.
- (struct objc_method_description_list): Do not define here.
- (__objc_register_instance_methods_to_class): Use struct
- objc_method_list * instead of MethodList_t and Method instead of
- Method_t.
-
-2010-12-14 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * selector.c: Reindented some code and tidied up comments. No
- actual code changes.
-
-2010-12-13 Iain Sandoe <iains@gcc.gnu.org>
-
- * encoding.c (_darwin_rs6000_special_round_type_align): New.
- (darwin_rs6000_special_round_type_align): Adjust to use new routine.
-
-2010-12-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * sendmsg.c (selector_resolveClassMethod): New.
- (selector_resolveInstanceMethod): New.
- (__objc_resolve_class_method): New.
- (__objc_resolve_instance_method): New.
- (get_imp): Call __objc_resolve_class_method or
- __objc_resolve_instance_method at the appropriate time.
- (objc_msg_lookup): Same.
- (class_getClassMethod): Same.
- (class_getInstanceMethod): Same.
- (__objc_init_dispatch_tables): Initialize
- selector_resolveClassMethod and selector_resolveInstanceMethod.
- * objc/runtime.h: Updated documentation of class_getClassMethod,
- class_getInstanceMethod and class_getMethodImplementation.
-
-2010-12-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/module-abi-8.h (struct objc_symtab): Updated
- description of sel_ref_cnt and refs.
- * objc/deprecated/struct_objc_symtab.h (objc_symtab): Same change.
-
-2010-12-06 Dave Korn <dave.korn.cygwin@gmail.com>
-
- PR target/40125
- PR lto/46695
- * configure.ac (extra_ldflags_libobjc): Invoke ACX_LT_HOST_FLAGS.
- * Makefile.in (lt_host_flags): Import AC_SUBST'd value.
- * aclocal.m4: Regenerate.
- * configure: Regenerate.
-
-2010-12-03 Matthias Klose <doko@ubuntu.com>
-
- * configure.ac (VERSION): Bump the version to 3:0:0.
- * configure: Regenerate.
-
-2010-11-23 Richard Frith-Macdonald <rfm@gnu.org>
-
- * sendmsg.c (get_imp): Fixed call to __objc_get_forward_imp to
- pass nil as the receiver since we don't know the receiver at this
- point.
-
-2010-11-18 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * ivars.c: Include stdlib.h.
- * protocols.c: Same change.
-
-2010-10-24 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_SOURCE_FILES): Added accessors.m.
- * accessors.m: New.
- * init.c: Include objc-private/accessors.h.
- (__objc_exec_class): Call __objc_accessors_init.
- * objc-private/accessors.h: New.
-
-2010-10-17 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/message.h: Moved initial includes outside of extern "C".
- * objc/runtime.h: Add extern "C" for Objective-C++.
-
-2010-10-17 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (objc_send_load): Do not wait for NXConstantString to be
- registered before executing +load. There is no point if
- -fconstant-string-class=xxx is used when compiling all modules,
- as is the case for almost all users.
- * linking.m (__objc_linking): Do not try to forcefully link in
- NXConstantString.
-
-2010-10-16 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h: Updated comments.
- (class_addMethod): New.
- (class_addIvar): New.
- (class_replaceMethod): New.
- (objc_allocateClassPair): New.
- (objc_registerClassPair): New.
- (objc_disposeClassPair): New.
- * class.c (objc_allocateClassPair): New.
- (objc_registerClassPair): New.
- (objc_disposeClassPair): New.
- (class_getSuperclass): Return Nil if a class is in construction.
- * init.c (__objc_exec_class): Call __objc_init_class.
- (__objc_init_class): New.
- * ivars.c (class_copyIvarList): Return NULL if class is in
- construction. Do not lock the runtime mutex.
- (class_getInstanceVariable): Return NULL if class is in
- construction. Do not lock the runtime mutex.
- (class_addIvar): New.
- * sendmsg.c (class_addMethod): New.
- (class_replaceMethod): New.
- * objc-private/module-abi-8.h (__CLS_SETNOTINFO): New.
- (_CLS_IN_CONSTRUCTION): New.
- (CLS_IS_IN_CONSTRUCTION): New.
- (CLS_SET_IN_CONSTRUCTION): New.
- (CLS_SET_NOT_IN_CONSTRUCTION): New.
- * objc-private/runtime.h (__objc_init_class): New.
-
-2010-10-16 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (class_getSuperclass): Call __objc_resolve_class_links
- if the class is not resolved yet.
- * ivars.c (class_getInstanceVariable): Use class_getSuperclass.
-
-2010-10-16 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (class_getIvarLayout): New.
- (class_getWeakIvarLayout): New.
- (class_setIvarLayout): New.
- (class_setWeakIvarLayout): New.
- * ivars.c (class_getIvarLayout): New.
- (class_getWeakIvarLayout): New.
- (class_setIvarLayout): New.
- (class_setWeakIvarLayout): New.
-
-2010-10-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h (class_copyPropertyList): New.
- (class_getProperty): New.
- (property_getAttributes): New.
- (property_getName): New.
- * ivars.c (class_copyPropertyList): New.
- (class_getProperty): New.
- (property_getAttributes): New.
- (property_getName): New.
-
-2010-10-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/runtime.h (__objc_update_classes_with_methods): New.
- * class.c (__objc_update_classes_with_methods): New.
- (objc_getClassList): Do not lock the class lock.
- * methods.c (method_exchangeImplementations): New.
- (method_setImplementation): New.
- * objc/runtime.h (method_setImplementation): New.
- (method_exchangeImplementations): New.
-
-2010-10-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Protocol.m: Include objc/runtime.h and
- objc-private/module-abi-8.h instead of objc/objc-api.h. Do not
- repeat Protocol's instance variables.
- (struct objc_method_description_list): Do not define here.
- ([-conformsTo:]): Reimplemented on top of protocol_conformsTo().
- ([descriptionForInstanceMethod:]): Use sel_isEqual() to compare
- selectors directly instead of getting names and then using strcmp.
- ([descriptionForClassMethod:]): Same change.
- ([-isEqual:]): Reimplemented on top of protocol_isEqual().
- * protocols.c (protocol_getMethodDescription): Use sel_isEqual()
- to compare selectors directly instead of getting names and then
- using strcmp.
- * objc/Protocol.h: Updated comments.
-
-2010-10-15 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * init.c (__objc_init_protocol): New function which fixes up a
- protocol's class pointer, registers it with the runtime, register
- all protocol selectors and registers associated protocols too.
- (objc_init_statics): Detect if we are initializing protocols, and
- if so, use __objc_init_protocol instead of only fixing up the
- class pointer.
- (__objc_init_protocls): Use __objc_init_protocol.
- * objc-private/module-abi-8.h: Updated comments.
- * objc-private/runtime.h
- (__objc_register_selectors_from_description_list): New.
- * selector.c (__objc_register_selectors_from_description_list):
- New. (struct objc_method_description_list): Declare.
- * Protocol.m ([-descriptionForInstanceMethod:]): Use sel_get_name
- when accessing the name of a method, which is now correctly a SEL.
- ([-descriptionForClassMethod:]): Same change.
- * protocols.c (protocol_getMethodDescription): Same change.
- * objc/runtime.h: Updated comments.
- (sel_registerTypedName): Fixed typo in function name.
-
-2010-10-13 Nicola Pero <nicola.pero@meta-innovation.com>
-
- PR libobjc/23214
- * init.c (objc_init_statics): Do not skip the initialization of a
- statics list if the first object has already been initialized; in
- the case of Protocols, while the first one may have been
- initialized, some others may not have been initialized yet.
-
-2010-10-13 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Added
- objc_get_uninstalled_dtable, objc_object_alloc.h and
- struct_objc_static_instances.h.
-
-2010-10-13 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * encoding.c (method_copyReturnType): New.
- (method_copyArgumentType): New.
- (method_getReturnType): New.
- (method_getArgumentType): New.
- * methods.c (method_getDescription): New.
- * objc/runtime.h (method_copyReturnType): New.
- (method_copyArgumentType): New.
- (method_getReturnType): New.
- (method_getArgumentType): New.
- (method_getDescription): New.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * encoding.c: Tidied up comments.
- (objc_skip_variable_name): New static inline function.
- (objc_sizeof_type): Use objc_skip_variable_name instead of copying
- the same code over and over.
- (objc_alignof_type): Same.
- (objc_aligned_size): Same.
- (objc_promoted_size): Same.
- (objc_skip_typespec): Same.
- (objc_layout_structure_next_member): Same.
- (objc_skip_offset): Skip a '-' before the digits (if any). Fixed
- historical bug where objc_skip_offset would skip one byte even if
- there is no offset: check that the first offset digit is actually
- a digit before skipping it.
- (objc_skip_type_qualifiers): Mark as inline.
- (objc_skip_typespec): Mark as inline.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (C_SOURCE_FILES): Added methods.c.
- * encoding.c (method_getNumberOfArguments): New.
- (method_get_number_of_arguments): Call
- method_getNumberOfArguments.
- * ivars.c (ivar_getName): Check for NULL variable argument.
- (ivar_getOffset): Check for NULL variable argument.
- (ivar_getTypeEncoding): Check for NULL variable argument.
- (class_copyIvarList): New.
- * methods.c: New.
- * protocols.c (class_copyProtocolList): Check for Nil class_
- argument.
- * sendmsg.c: Use 'struct objc_method *' instead of Method_t, and
- 'struct objc_method_list *' instead of MethodList_t.
- (class_getMethodImplementation): New.
- (class_respondsToSelector): New.
- (class_getInstanceMethod): New.
- (class_getClassMethod): New.
- * objc/runtime.h: Updated comments.
- (class_copyIvarList): New.
- (class_getInstanceMethod): New.
- (class_getClassMethod): New.
- (class_getMethodImplementation): New.
- (class_respondsToSelector): New.
- (method_getName): New.
- (method_getImplementation): New.
- (method_getTypeEncoding): New.
- (class_copyMethodList): New.
- (method_getNumberOfArguments): New.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c: Include objc/runtime.h and objc-private/module-abi-8.h
- instead of objc/objc-api.h.
- (objc_get_unknown_class_handler): Do not define.
- (class_isMetaClass): New.
- (class_getSuperclass): New.
- (class_getVersion): New.
- (class_setVersion): New.
- (class_getInstanceSize): New.
- * exceptions.c: Include objc/runtime.h instead of objc/objc-api.h.
- (is_kind_of_exception_matcher): Use objc_getSuperclass instead of
- objc_get_super_class.
- (get_ttype_entry): Use objc_getRequiredClass instead of
- objc_get_class.
- * ivars.c (class_getClassVariable): New.
- * objects.c: Include objc/runtime.h, objc/thr.h and
- objc-private/module-abi-8.h instead of objc/objc-api.h
- * objc/runtime.h (class_getClassVariable): New.
- (class_isMetaClass): New.
- (class_getSuperclass): New.
- (class_getVersion): New.
- (class_setVersion): New.
- (class_getInstanceSize): New.
- * objc-private/module-abi-8.h (HOST_BITS_PER_LONG): New (from
- objc/objc-api.h)
- (__CLS_INFO): Same.
- (__CLS_ISINFO): Same.
- (__CLS_SETINFO): Same.
- (CLS_ISMETA): Same.
- (CLS_ISCLASS): Same.
- (CLS_ISRESOLV): Same.
- (CLS_SETRESOLV): Same.
- (CLS_ISINITIALIZED): Same.
- (CLS_SETINITIALIZED): Same.
- (CLS_GETNUMBER): Same.
- (CLS_SETNUMBER): Same.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * archive.c: Do not include objc/objc.h.
- * class.c: Do not include objc/objc.h.
- * encoding.c: Include objc/runtime.h, ctype.h and
- objc-private/module-abi-8.h instead of objc/objc-api.h and
- objc/encoding.h.
- * error.c: Do not include objc/objc.h.
- * gc.c: Include tconfig.h and objc/encoding.h only if
- OBJC_WITH_GC.
- * hash.c: Include objc/runtime.h and objc/thr.h instead of
- objc/objc-api.h. Do not include objc/objc.h.
- * init.c: Do not include objc/objc.h.
- * ivars.c: Include objc/runtime.h, objc-private/module-abi-8.h and
- objc/thr.h instead of objc/objc-api.h. Do not include
- objc/objc.h.
- * linking.m: Tidied comment.
- * memory.c: Include objc/runtime.h instead of objc/objc-api.h.
- Do not include objc/objc.h.
- * objects.c: Do not include objc/objc.h.
- * objc-sync.c: Include objc/runtime.h instead of objc/objc-api.h.
- * protocols.c: Do not include objc/objc.h.
- * sarray.c: Include objc/runtime.h instead of objc/objc-api.h. Do
- not include objc/objc.h.
- * selector.c: Do not include objc/objc.h.
- * sendmsg.c: Do not include objc/objc.h.
- * thr.c: Include objc/runtime.h instead of objc/objc-api.h.
- Do not include objc/objc.h.
- * objc/objc-decls.h: Reindented code.
- * objc/runtime.h Include objc-decls.h. Updated comments.
- (objc_malloc): New.
- (objc_atomic_malloc): New.
- (objc_calloc): New.
- (objc_realloc): New.
- (objc_free): New.
- * objc-private/runtime.h: Updated comments.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (C_SOURCE_FILES): Added protocols.c.
- * objc-private/protocols.h: New.
- * protocols.c: New.
- * init.c: Include objc-private/protocols.h.
- (__objc_exec_class): Call __objc_protocols_init on startup.
- (__objc_init_protocols): Call __objc_protocols_add_protocol.
- * objc-private/runtime.h: Use (struct objc_method_list *) instead
- of MethodList_t, and (struct objc_method *) instead of Method_t.
- * objc/deprecated/struct_objc_class.h: Define
- __objc_STRUCT_OBJC_CLASS_defined.
- * objc-private/module-abi-8.h (struct
- objc_method_description_list): New.
- (struct objc_class): Only define if
- __objc_STRUCT_OBJC_CLASS_defined is undefined.
- * objc/runtime.h (class_getName): New.
- (objc_getProtocol): New.
- (objc_copyProtocolList): New.
- (class_addProtocol): New.
- (class_conformsToProtocol): New.
- (class_copyProtocolList): New.
- (protocol_conformsToProtocol): New.
- (protocol_isEqual): New.
- (protocol_getName): New.
- (protocol_getMethodDescription): New.
- (protocol_copyMethodDescriptionList): New.
- (protocol_getProperty): New.
- (protocol_copyPropertyList): New.
- (protocol_copyProtocolList): New.
- * class.c (class_getName): New.
- * selector.c (sel_isEqual): New.
-
-2010-10-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * selector.c (sel_getName): Return "<null selector>" for a NULL
- argument.
- (sel_get_name): Return 0 for a NULL argument.
- * objc/runtime.h (sel_getName): Updated documentation.
-
- * objc-private/hash.h (class_hash_table): Unused declaration
- removed.
- (module_hash_table): Same.
- * objc/deprecated/hash.h: Same changes.
-
-2010-10-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * class.c (objc_getClassList): New.
- (objc_getRequiredClass): New.
- (objc_getMetaClass): New.
- (objc_lookupClass): New.
- (objc_getClass): New.
- (__objc_get_unknown_class_handler): New.
- (objc_setGetUnknownClassHandler): New.
- (objc_get_class): Use __objc_get_unknown_class_handler.
- (objc_lookup_class): Call objc_getClass.
- * objc/objc-api.h: Updated comment and copyright notice.
- * objc/runtime.h: Updated comments.
- (objc_getClass): New.
- (objc_lookupClass): New.
- (objc_getMetaClass): New.
- (objc_getRequiredClass): New.
- (objc_getClassList): New.
- (objc_setGetUnknownClassHandler): New.
- (objc_get_unknown_class_handler): New.
- * objc-private/runtime.h: Use __objc_private_runtime_INCLUDE_GNU
- instead of __objc_runtime_INCLUDE_GNU as include guard.
- * objc-private/error.h (_objc_abort): Mark as noreturn.
-
-2010-10-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (C_SOURCE_FILES): Added ivars.c.
- * ivars.c: New.
- * objc/objc.h: Updated comments.
- * objc/runtime.h (object_getClass): New.
- (object_getClassName): New.
- (object_setClass): New.
- (class_getInstanceVariable): New.
- (object_getIndexedIvars): New.
- (object_getInstanceVariable): New.
- (object_setInstanceVariable): New.
- (object_getIvar): New.
- (object_setIvar): New.
- (ivar_getName): New.
- (ivar_getOffset): New.
- (ivar_getTypeEncoding): New.
- * objc-private/module-abi-8.h (struct objc_class): Added.
- * objects.c (object_getClassName): New.
- (object_setClass): New.
-
-2010-10-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc.h: Updated comments.
- * objc/objc-api.h: (object_copy): Added one argument; use a
- #define to maintain backwards-compatibility. Moved
- _objc_object_alloc, _objc_object_copy, _objc_object_dispose and
- objc_get_uninstalled_dtable into
- objc/deprecated/objc_get_uninstalled_dtable.h and
- objc/deprecated/objc_object_alloc.h. Include these files.
- * objc/deprecated/objc_get_uninstalled_dtable.h: New.
- * objc/deprecated/objc_object_alloc.h: New.
- * objc/runtime.h (set_getName): New.
- (sel_getType): New.
- (sel_getUid): New.
- (sel_registerName): New.
- (sel_registerTypedName): New.
- (sel_isEqual): New.
- (class_createInstance): New.
- (object_copy): New.
- (object_dispose): New.
- * objects.c: Do not include tconfig.h. Include gc_typed.h if
- building the garbage collection version.
- (__objc_object_alloc): Removed.
- (__objc_object_copy): Removed.
- (__objc_object_dispose): Removed.
- (class_createInstance): New from code in class_create_instance.
- Cast second argument of GC_malloc_explicitly_typed. Use
- objc_calloc. Do not call _objc_object_alloc.
- (class_create_instance): Call class_createInstance.
- (object_copy): Added extraBytes argument. Do not call
- _objc_object_copy.
- (object_dispose): Do not call _objc_object_dispose.
- * memory.c (objc_free): When using garbage collection, mark the
- argument as unused.
- * selector.c (sel_getName): New.
- (sel_get_name): Call sel_getName.
- (sel_getType): New.
- (sel_get_type): Call sel_getType.
- (sel_registerName): New.
- (sel_register_name): Call sel_registerName.
- (sel_registerTypedName): New.
- (sel_register_typed_name): Call sel_registerTypedName.
- (sel_getUid): New.
- (sel_get_uid): Call sel_getUid.
-
-2010-10-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-api.h: Define Method, Method_t, Category and
- Category_t. Prevent including this file at the same time as
- objc/runtime.h. Updated comments.
- * objc/deprecated/struct_objc_method.h: Do not define Method,
- Method_t.
- * objc/deprecated/struct_objc_category.h: Do not define Category,
- Category_t.
- * objc-private/module-abi-8.h: New file containing a copy of all
- the structure definitions. Not used yet.
- * objc/encoding.h (objc_aligned_size): Removed duplicate
- declaration. Updated comments.
- * objc/runtime.h: Added Ivar, objc_property_t, Property, Method,
- Category, struct objc_method_description, _C_ID and similar,
- _C_CONST and similar and _F_CONST and similar. Added
- objc_sizeof_type, objc_alignof_type, objc_aligned_size,
- objc_promoted_size, objc_skip_type_qualifier, objc_skip_typespec,
- objc_skip_offset, objc_skip_argspec, objc_get_type_qualifiers,
- struct objc_struct_layout, objc_layout_structure,
- objc_layout_structure_next_member, objc_layout_finish_structure,
- objc_layout_structure_get_info. Prevent including this file at
- the same time as objc/objc-api.h.
-
-2010-10-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (OBJC_DEPRECATED_H): Added struct_objc_category.h,
- struct_objc_ivar.h, struct_objc_ivar_list.h, struct_objc_method.h,
- struct_objc_method_list.h, struct_objc_module.h,
- struct_objc_protocol_list.h, struct_objc_symtab.h.
- * objc/deprecated/struct_objc_category.h: New.
- * objc/deprecated/struct_objc_ivar.h: New.
- * objc/deprecated/struct_objc_ivar_list.h: New.
- * objc/deprecated/struct_objc_method.h: New.
- * objc/deprecated/struct_objc_method_list.h: New.
- * objc/deprecated/struct_objc_module.h: New.
- * objc/deprecated/struct_objc_protocol_list.h: New.
- * objc/deprecated/struct_objc_symtab.h: New.
- * objc/deprecated/struct_objc_static_instances.h: New.
- * objc/objc-api.h: Definitions of deprecated structures moved into
- the above header fragment files in objc/deprecated/. Include the
- files instead of definition the structures here. Updated
- comments.
- * objc/runtime.h: Updated comments. Do not include objc-api.h.
- (objc_set_enumeration_mutation_handler): Renamed to
- objc_setEnumerationMutationHandler.
- * objc-foreach.c (objc_set_enumeration_mutation_handler): Renamed
- to objc_setEnumerationMutationHandler.
- * objc/objc-exception.h (objc_set_exception_matcher): Renamed to
- objc_setExceptionMatcher.
- (objc_set_uncaught_exception_handler): Renamed to
- objc_setUncaughtExceptionHandler.
- * exception.c: Same changes.
-
-2010-10-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-sync.c: Include objc-private/common.h.
-
-2010-10-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-foreach.c: Include objc-private/common.h.
- * objc/deprecated/METHOD_NULL.h: New file.
- * objc/objc-api.h: Include deprecated/METHOD_NULL.h instead of
- defining METHOD_NULL here.
- * Makefile.in (OBJC_DEPRECATED_H): Added METHOD_NULL.h.
- * Object.m ([+instancesRespondTo:]): Use (Method_t)0 instead of
- METHOD_NULL.
- ([-respondsTo:]): Same change.
- * objc/objc-api.h (method_get_imp): Converted it into a normal
- function so that we can hide the internals of struct objc_method.
- * sendmsg.c (method_get_imp): Implemented.
-
-2010-10-09 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-api.h (struct objc_super, Super, Super_t,
- objc_msg_lookup_super, objc_msg_sendv, objc_msg_forward,
- objc_msg_forward2): Declarations moved to objc/message.h. Include
- message.h here.
- * objc/message.h: Added such declarations; updated comments.
-
-2010-10-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- Implemented fast enumeration for Objective-C.
- * Makefile.in (C_SOURCE_FILES): Added objc-foreach.c.
- (OBJC_H): Added runtime.h
- * objc-foreach.c: New file.
- * objc/runtime.h: New file.
-
-2010-09-30 Kai Tietz <kai.tietz@onevision.com>
-
- * objc/deprecated/struct_objc_class.h: Add padding
- to avoid warning with -Wpadded.
-
-2010-09-26 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * encoding.c (objc_sizeof_type): Added support for vector type and
- for double long types.
- (objc_alignof_type): Same change.
- (objc_skip_typespec): Same change.
- * objc/encoding.h (_C_GCINVISIBLE): Use '|' for _C_GCINVISIBLE
- instead of '!' since '!' is already used for _C_VECTOR.
- * objc/objc-api.h (_C_LNG_DBL): Added.
-
-2010-09-26 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * libobjc_entry.c: File removed.
-
-2010-09-26 Kai Tietz <kai.tietz@onevision.com>
-
- * sendmsg.c (objc_msg_lookup): Remove inline.
- (objc_get_uninstalled_dtable): Likewise.
- * encoding.c (objc_skip_type_qualifiers): Likewise.
- (objc_skip_offset): Likewise.
- * archive.c (__objc_write_object): Likewise
- (__objc_write_class):
- (__objc_write_selector):
- (objc_read_char):
- (objc_read_unsigned_char):
- (objc_read_short):
- (objc_read_unsigned_short):
- (objc_read_int):
- (objc_read_long):
- (__objc_read_nbyte_uint):
- (objc_read_unsigned_int):
- (objc_read_unsigned_long):
- * objc/objc-decls.h (obc_EXPORT): Remove dllexport for DLL_EXPORT case.
- (objc_EXPORT): Likewise.
- * objc/message.h (objc-decls.h): Add include.
- * objc/objc-api.h: Mark API by objc_EXPORT.
- * libobjc.def (__objc_responds_to): Removed.
-
-2010-09-18 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * hash.c: Include objc-private/hash.h instead of objc/hash.h.
-
- * objc/sarray.h: Moved into objc/deprecated/sarray.h;
- objc/sarray.h replaced with a placeholder including the file from
- the deprecated/ directory.
- * objc-private/sarray.h: New file (private copy of sarray.h).
- * hash.c: Include <assert.h> instead of "assert.h"
- * sarray.c: Include <assert.h> instead of "assert.h". Include
- objc-private/sarray.h instead of objc/sarray.h.
- * selector.c: Include objc-private/sarray.h instead of
- objc/sarray.h.
- * sendmsg.c: Include <assert.h>. Include objc-private/sarray.h
- instead of objc/sarray.h.
- * Makefile.in (OBJC_DEPRECATED_H): Added sarray.h.
-
-2010-09-17 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc-private/objc-list.h (list_remove_elem): Unused function
- removed. (list_nth): Unused function removed. (list_find):
- Unused function removed. (list_lenght): Unused function removed.
-
-2010-09-17 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/hash.h: Moved into objc/deprecated/hash.h; objc/hash.h
- replaced with a placeholder including the file from the
- deprecated/ directory.
- * objc/objc-api.h: Updated includes.
- * objc/typedstream.h: Updated includes.
- * objc-private/hash.h: New file (private copy of hash.h).
- * objc/objc-list.h: Moved into objc/deprecated/objc-list.h;
- objc/objc-list.h replaced with a placeholder including the file
- from the deprecated/ directory.
- * objc-private/objc-list.h: New file (private copy of objc-list.h).
- * init.c: Include objc-private/hash.h and objc-private/objc-list.h
- instead of objc/hash.h and objc/objc-list.h.
- * selector.c: Same change.
- * class.c: Added include <string.h>, which used to be implicitly included
- when hash.h was included.
- * exception.c: Same change.
- * objects.c: Same change.
- * sarray.c: Same change.
- * sendmsg.c: Same change.
- * Makefile.in (OBJC_DEPRECATED_H): Added hash.h and objc-list.h.
-
-2010-09-14 Nicola Pero <nicola.pero@meta-innovation.com>
-
- Implemented objc_sync_enter() and objc_sync_exit(), which are
- required by @synchronized() to work.
- * objc-sync.c: New file.
- * objc/objc-sync.h: New file.
- * objc-private/objc-sync.h: New file.
- * init.c (__objc_exec_class): Call __objc_sync_init() during the
- Objective-C runtime startup.
- * Makefile.in: Added objc-sync.c and objc-sync.h.
- * configure.ac: Added GCC_CHECK_TLS.
- * acinclude.m4: Include ../config/enable.m4 and ../config/tls.m4.
- * configure: Regenerated.
- * config.h.in: Regenerated.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Makefile.in (%_gc.lo): New pattern rules to build the
- garbage-collected version of the library. Removed rules for
- specific files that are no longer needed. Standardized all rules.
- (C_SOURCE_FILES, OBJC_SOURCE_FILES): New variables.
- (OBJS, OBJS_GC): Compute these from C_SOURCE_FILES and
- OBJC_SOURCE_FILES.
- (INCLUDES): Removed the unused include -I$(srcdir)/objc.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * memory.c (objc_calloc): Fixed call to GC_malloc when building
- with Garbage Colletion.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * memory.c: Do not include objc-private/runtime.h.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/deprecated/objc_malloc.h: New file.
- * objc/deprecated/objc_valloc.h: New file.
- * objc/objc-api.h: Include the files instead of defining
- objc_valloc, _objc_malloc() and similar.
- * Makefile.in (OBJC_DEPRECATED_H): Added objc_valloc.h and
- objc_malloc.h.
- * memory.c: Removed the extra layer of indirection of _objc_malloc
- and similar.
- (objc_calloc): Use GC_malloc in the garbage-collected
- implementation as GC_malloc returns memory that is already freed.
- (objc_valloc): Deprecated.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/deprecated/objc_error.h: New file.
- * objc/objc-api.h: Include deprecated/objc_error.h instead of
- defining objc_error and related.
- * error.c: New file. Added _objc_abort function which replaces
- objc_error. No change in functionality as they both print an
- error and abort.
- * misc.c: File removed. Code moved into memory.c and error.c.
- * memory.c: New file.
- * objc-private/error.h: New file.
- * archive.c: Include objc-private/error.h and use _objc_abort
- instead of objc_error everywhere.
- * class.c: Same change.
- * encoding.c: Same change.
- * init.c: Same change, and simplified init_check_module_version.
- * memory.c: Same change.
- * sendmsg.c: Same change.
- * thr.c: Same change.
- * Makefile.in (OBJ_DEPRECATED_H): Added objc_error.h.
- (OBJ_H): Reordered list.
- (OBJS): Removed misc.lo, added memory.lo and error.lo.
- (OBJS_GC): Removed misc_gc.lo, added memory_gc.lo and error_gc.lo.
- (misc_gc.lo): Rule removed.
- (error_gc.lo): Rule added.
- (memory_gc.lo): Rule added.
-
-2010-09-12 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc.h (__GNU_LIBOBJC__): New #define providing an easy way
- to check the API version. Added some comments.
-
- * objc-private/common.h: New file.
- * NXConstStr.m: Include objc-private/common.h.
- * Object.m: Same change.
- * Protocol.m: Same change.
- * archive.c: Same change.
- * class.c: Same change.
- * encoding.c: Same change.
- * exception.c: Same change.
- * gc.c: Same change.
- * hash.c: Same change.
- * init.c: Same change.
- * libobjc_entry.c: Same change.
- * linking.m: Same change.
- * misc.c: Same change (and added a comment).
- * nil_method.c: Same change.
- * objects.c: Same change.
- * sarray.c: Same change.
- * selector.c: Same change.
- * sendmsg.c: Same change.
- * thr.c: Same change.
-
-2010-09-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-api.h: Removed obsolete #ifdef for NeXTSTEP.
-
-2010-09-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * archive.c: Removed not needed includes.
- * class.c: Same change.
- * hash.c: Same change.
- * misc.c: Same change.
- * nil_method.c: Same change.
- * objects.c: Same change.
- * sarray.c: Same change.
- * sendmsg.c: Same change.
- * thr.c: Same change.
-
-2010-09-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/runtime.h: Moved to objc-private/runtime.h. Do not include
- all the objc/*.h files.
- * objc-private/runtime.h: New file.
- * archive.c: Include objc-private/runtime.h (and required objc/*.h
- files) instead of objc/runtime.h.
- * class.c: Same change.
- * hash.c: Same change.
- * init.c: Same change.
- * misc.c: Same change.
- * nil_method.c: Same change.
- * objects.c: Same change.
- * sarray.c: Same change.
- * selector.c: Same change.
- * sendmsg.c: Same change.
- * thr.c: Same change.
-
-2010-09-11 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/deprecated/struct_objc_selector.h: New file. Definition of
- 'struct objc_selector' and 'sel_eq' moved here.
- * objc/deprecated/struct_objc_protocol.h: New file. Definition of
- 'struct objc_procotol' moved here.
- * objc/deprecated/struct_objc_class.h: New file. Definition of
- 'struct objc_class' moved here.
- * objc/deprecated/MetaClass.h: New file. Definition of MetClass
- moved here.
- * objc/deprecated/STR.h: New file. Definition of STR moved here.
- * objc/message.h: New file. Definitions for relval_t, apply_t,
- arglist, arglist_t and objc_msg_lookup were moved here.
- * objc/objc.h: Include the above files instead of defining the
- corresponding structs, types and functions here. Added new opaque
- definitions for SEL and Class. Use Class and not 'struct
- objc_class *' in the definition of 'struct objc_object'.
- Commented all types defined in the file. Removed special
- definition of BOOL as 'int' on __vxworks; use 'unsigned char'
- there as well.
- * objc/deprecated/objc-unexpected-exception.h: Renamed to
- objc_unexpected_exception.h.
- * objc/objc-api.h: Updated include of
- objc-unexpetected-exception.h
- * objc/objc-exception.h: Updated comments.
- * Makefile.in (OBJC_H, OBJC_DEPRECATED_H): Added the new header
- files. Reindented list of files.
-
-2010-09-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-api.h (objc_trace): Unused variable removed.
-
-2010-09-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/deprecated: New directory.
- * objc/deprecated/README: New file.
- * objc/README: New file.
- * objc/typedstream.h: Moved into objc/deprecated/typedstream.h;
- objc/typedstream.h replaced with a placeholder including the file
- from the deprecated/ directory.
- * objc/deprecated/objc-unexpected-exception.h: New file with the
- definition of _objc_unexpected_exception.
- * objc/objc-api.h: Include deprecated/objc-unexcepted-exception.h
- instead of defining _objc_unexpected_exception.
- * objc/deprecated/Object.h: New file with the deprecated Object
- methods in a 'Deprecated' category.
- * objc/Object.h Include deprecated/Object.h instead of defining
- the deprecated methods.
- * Object.m: Moved deprecated methods into 'Deprecated' category.
- * objc-private: New directory.
- * objc-private/README: New file.
- * Makefile.in (OBJC_DEPRECATED_H): New variable.
- (install-headers): Create installation directory for
- OBJC_DEPRECATED_H headers, and install them.
-
-2010-09-10 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-exception.h: Fixed include of objc.h.
-
-2010-09-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/objc-exception.h: New file.
- * exception.c (objc_set_uncaught_exception_handler): Implemented.
- (objc_set_exception_matcher): Implemented.
- (objc_exception_throw): Use the uncaught exception handler if set.
- (PERSONALITY_FUNCTION): Use the exception matcher instead of the
- hardcoded isKindOf.
- (isKindOf): Renamed to is_kind_of_exception_matcher. Tidied code
- up. Removed segmentation fault when value is 'nil'.
- * objc/objc-api.h (_objc_unexpected_exception): Mark as
- deprecated.
- * Makefile.in (exception.lo, exception_gc.lo): Use
- -Wno-deprecated-declarations when compiling.
- (OBJC_H): Added objc-exception.h
-
-2010-09-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * objc/typedstream.h: Deprecate all functions in the file. This
- file is obsolete.
- * objc/Object.h ([+streamVersion:], [-read:], [-write:],
- [-awake]): Documented that these methods are deprecated. Added a
- brief description of the Object class and its relationship to the
- NSObject class.
- * Makefile.in: Compile archive.c and Object.m with
- -Wno-deprecated-declarations.
-
-2010-09-08 Nicola Pero <nicola.pero@meta-innovation.com>
-
- Removed obsolete intermediate threading layer.
- * thr.c: Use __gthread_objc_xxx functions directly instead of
- __objc_thread_xxx ones.
- * objc/thr.h: Removed prototypes of no longer existing
- __objc_thread_xxx functions.
- * Makefile.in: Removed thr-objc.lo.
- * thr-dce.c: File removed.
- * thr-decosf1.c: File removed.
- * thr-irix.c: File removed.
- * thr-mach.c: File removed.
- * thr-objc.c: File removed.
- * thr-os2.c: File removed.
- * thr-posix.c: File removed.
- * thr-pthreads.c: File removed.
- * thr-rtems.c: File removed.
- * thr-single.c: File removed.
- * thr-solaris.c: File removed.
- * thr-vxworks.c: File removed.
- * thr-win32.c: File removed.
- * README.threads: File removed.
- * THREADS.MACH: File removed.
- * THREADS: Updated.
-
-2010-09-07 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * Object.m (MAX_CLASS_NAME_LEN): Unused define removed.
-
-2010-09-06 Iain Sandoe <iains@gcc.gnu.org>
-
- * encoding.c: Add TARGET_ALIGN_NATURAL definition for m64 powerpc darwin.
- Add a comment as to why, update FIXME comments.
-
-2010-09-06 Nicola Pero <nicola.pero@meta-innovation.com>
-
- * makefile.dos: Obsolete file removed.
-
-2010-04-02 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * aclocal.m4: Regenerate.
-
-2010-03-23 Dave Korn <dave.korn.cygwin@gmail.com>
-
- PR libobjc/30445
- * configure.ac (extra_ldflags_libobjc): Define appropriately for
- Cygwin and MinGW hosts.
- * Makefile.am (libobjc_s.a): Remove dead pre-libtool target.
- (libobjc.dll): Likewise.
- * configure: Regenerate.
-
-2009-12-05 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure: Regenerate.
-
-2009-11-28 Jakub Jelinek <jakub@redhat.com>
-
- * sarray.c (sarray_free): Use old_buckets variable.
- * encoding.c (objc_layout_structure_next_member): Remove unused
- bfld_type_size variable.
-
-2009-08-24 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure.ac (AC_PREREQ): Bump to 2.64.
-
-2009-08-22 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * aclocal.m4: Regenerate.
- * configure: Regenerate.
- * config.h.in: Regenerate.
-
-2009-08-22 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * Makefile.in (LIBTOOL): Add $(LIBTOOLFLAGS).
-
-2009-07-30 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * Makefile.in (AUTOCONF, ACLOCAL, ACLOCAL_AMFLAGS, aclocal_deps):
- New variables.
- ($(srcdir)/configure, $(srcdir)/aclocal.m4): New rules.
-
-2009-07-30 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure.ac (_AC_ARG_VAR_PRECIOUS): Use m4_rename_force.
-
-2009-04-09 Nick Clifton <nickc@redhat.com>
-
- * sendmsg.c: Change copyright header to refer to version 3 of
- the GNU General Public License with version 3.1 of the GCC
- Runtime Library Exception and to point readers at the COPYING3
- and COPYING3.RUNTIME files and the FSF's license web page.
- * NXConstStr.m: Likewise.
- * Object.m: Likewise.
- * Protocol.m: Likewise.
- * archive.c: Likewise.
- * class.c: Likewise.
- * encoding.c: Likewise.
- * exception.c: Likewise.
- * gc.c: Likewise.
- * hash.c: Likewise.
- * init.c: Likewise.
- * libobjc_entry.c: Likewise.
- * linking.m: Likewise.
- * misc.c: Likewise.
- * nil_method.c: Likewise.
- * objc/NXConstStr.h: Likewise.
- * objc/Object.h: Likewise.
- * objc/Protocol.h: Likewise.
- * objc/encoding.h: Likewise.
- * objc/hash.h: Likewise.
- * objc/objc-api.h: Likewise.
- * objc/objc-decls.h: Likewise.
- * objc/objc-list.h: Likewise.
- * objc/objc.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc/sarray.h: Likewise.
- * objc/thr.h: Likewise.
- * objc/typedstream.h: Likewise.
- * objects.c: Likewise.
- * sarray.c: Likewise.
- * selector.c: Likewise.
- * thr-dce.c: Likewise.
- * thr-decosf1.c: Likewise.
- * thr-irix.c: Likewise.
- * thr-mach.c: Likewise.
- * thr-objc.c: Likewise.
- * thr-os2.c: Likewise.
- * thr-posix.c: Likewise.
- * thr-pthreads.c: Likewise.
- * thr-rtems.c: Likewise.
- * thr-single.c: Likewise.
- * thr-solaris.c: Likewise.
- * thr-vxworks.c: Likewise.
- * thr-win32.c: Likewise.
- * thr.c: Likewise.
- * libobjc.def: Change copyright header to refer to version 3 of
- the GNU General Public License and to point readers at the COPYING3
- file and the FSF's license web page.
- * makefile.dos: Likewise.
-
-2009-04-09 Jakub Jelinek <jakub@redhat.com>
-
- * Makefile.in: Change copyright header to refer to version
- 3 of the GNU General Public License and to point readers at the
- COPYING3 file and the FSF's license web page.
- * configure.ac: Likewise.
-
-2009-03-12 Richard Frith-Macdonald <rfm@gnu.org>
- David Ayers <ayers@fsfe.org>
-
- PR libobjc/27466
- * objc/objc-api.h (_objc_unexpected_exception): Declare
- new hook. Update copyright dates.
- * exception.c (objc_exception_throw): Use hook. Update
- copyright dates.
- * libobjc.def (_objc_unexpected_exception): Export hook.
- Update copyright dates.
-
-2009-03-01 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure: Regenerate.
-
-2008-12-18 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure: Regenerate.
-
-2008-11-21 Kai Tietz <kai.tietz@onevision.com>
-
- * Object.m (errno): Replaced by errno.h include.
- (compare): Cast self to id to prevent warning on comparison.
- * objc/objc.h (BOOL): Prevent redeclaration of BOOL, if it is
- already there.
- * sendmsg.c (__objc_print_dtable_stats): Remove type warnings.
- * thr-win32.c (__objc_thread_detach): Remove type warning.
- (__objc_thread_id): Likewise.
- * thr.c (__objc_thread_detach_functiont): Add __builtin_trap ()
- for noreturn.
-
-2008-09-26 Peter O'Gorman <pogma@thewrittenword.com>
- Steve Ellcey <sje@cup.hp.com>
-
- * configure: Regenerate for new libtool.
- * config.h.in: Regenerate for new libtool.
-
-2008-07-18 Matthias Klose <doko@ubuntu.com>
-
- * Makefile.in: Ignore missing ../boehm-gc/threads.mk.
-
-2008-07-18 Matthias Klose <doko@ubuntu.com>
-
- * Makefile.in: Include ../boehm-gc/threads.mk.
- (OBJC_BOEHM_GC_LIBS): Define, (libobjc_gc$(libsuffix).la): Use it.
-
-2008-07-06 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * Makefile.in (install-info): New stub target.
-
-2008-06-17 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
-
- * configure: Regenerate.
-
-2008-06-14 Kai Tietz <kai.tietz@onevision.com>
-
- * exception.c (PERSONALITY_FUNCTION): Remove extra decrement
- if HAVE_GETIPINFO is not defined.
-
-2008-06-10 Kai Tietz <kai.tietz@onevision.com>
-
- * Object.m (compare): Add type id.
- * objc/Object.h: Likewise.
- * archive.c (objc_read_class): Use size_t to extend version to be
- size of pointer scalar width.
- * sendmsg.c (rtx): Undefine it before redefinition.
- (__objc_print_dtable_stats): Cast arguments to long as intended.
-
-2008-05-30 Julian Brown <julian@codesourcery.com>
-
- * exception.c (__objc_exception_class): Initialise as constant
- array for ARM EABI. Change macro to static const for non-ARM EABI.
- (ObjcException): Add note about structure layout. Remove landingPad
- and handlerSwitchValue for ARM EABI.
- (get_ttype_entry): Add __ARM_EABI_UNWINDER__ version
- of function.
- (CONTINUE_UNWINDING): Define for ARM EABI/otherwise cases.
- (PERSONALITY_FUNCTION): Use ARM EABI-specific arguments, and add
- ARM EABI unwinding support.
- (objc_exception_throw): Use memcpy to initialise exception class.
-
-2008-05-25 Alan Modra <amodra@bigpond.net.au>
-
- * encoding.c (strip_array_types): Rename from get_inner_array_type.
- (rs6000_special_round_type_align): Update.
-
-2008-05-09 Julian Brown <julian@codesourcery.com>
-
- * Makefile.in (LTLDFLAGS): New.
- (libobjc$(libsuffix).la, libobjc_gc$(libsuffix).la): Use above.
-
-2008-04-18 Paolo Bonzini <bonzini@gnu.org>
-
- PR bootstrap/35457
- * aclocal.m4: Regenerate.
- * configure: Regenerate.
-
-2008-01-24 David Edelsohn <edelsohn@gnu.org>
-
- * configure: Regenerate.
-
-2007-10-14 H.J. Lu <hongjiu.lu@intel.com>
-
- * configure.ac: Don't run config-ml.in directly.
- (multilib_arg): New.
- * configure: Regenerated.
-
-2007-08-06 Andrew Pinski <pinskia@gmail.com>
-
- PR libobjc/30731
- * exception.c (parse_lsda_header): Use _uleb128_t/_sleb128_t instead
- of _Unwind_Word for variables which are used in
- read_uleb128/read_sleb128.
- (PERSONALITY_FUNCTION): Likewise.
-
-2007-07-05 H.J. Lu <hongjiu.lu@intel.com>
-
- * aclocal.m4: Regenerated.
-
-2007-06-03 Andrew Pinski <andrew_pinski@playstation.sony.com>
-
- * configure.ac: Fix a typo in *-*-darwin clause.
- * configure: Regenerated.
-
-2007-06-02 H.J. Lu <hongjiu.lu@intel.com>
-
- * configure.ac: Fix a typo.
- * configure: Regenerated.
-
-2007-06-02 Paolo Bonzini <bonzini@gnu.org>
-
- * configure: Regenerate.
-
-2007-06-01 Andrew Pinski <andrew_pinski@playstation.sony.com>
-
- * Makefile.in: Replace all uses of libext with libsuffix.
- * configure.ac: Likewise.
- * configure: Regenerate.
-
- Revert:
- * Makefile.in: Remove all uses of $(libext).
-
-2007-05-23 Andrew Pinski <andrew_pinski@playstation.sony.com>
-
- * Makefile.in: Remove all uses of $(libext).
-
-2007-05-23 Steve Ellcey <sje@cup.hp.com>
-
- * configure: Regenerate.
- * aclocal.m4: Regenerate.
-
-2007-04-21 Andrew Ruder <andy@aeruder.net>
-
- * sendmsg.c (__objc_get_forward_imp): Call
- __objc_msg_forward2 for real.
-
-2007-04-09 Andrew Ruder <andy@aeruder.net>
-
- * sendmsg.c: Added __objc_msg_forward2, a hook that allows
- external libraries to provide a function that returns the real
- forwarding function based on both the selector and the receiver.
- * objc/objc-api.h: Define __objc_msg_forward2.
-
-2007-03-01 Brooks Moses <brooks.moses@codesourcery.com>
-
- * Makefile.in: Add dummy install-pdf target.
-
-2007-02-18 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
-
- * objc/objc-list.h (list_free): Add keyword 'inline' to avoid
- unused warning.
-
-2006-10-31 Geoffrey Keating <geoffk@apple.com>
-
- * encoding.c (darwin_rs6000_special_round_type_align): New.
-
-2006-10-14 Geoffrey Keating <geoffk@apple.com>
-
- * Makefile.in: Use multi_basedir instead of toplevel_srcdir.
- * configure.ac: Use multi.m4 from aclocal rather than custom
- code. Use multi_basedir instead of toplevel_srcdir.
- * aclocal.m4: Regenerate.
- * configure: Regenerate.
-
-2006-10-10 Brooks Moses <bmoses@stanford.edu>
-
- * Makefile.in: Added empty "pdf" target.
-
-2006-07-18 Paolo Bonzini <bonzini@gnu.org>
-
- * configure: Regenerate.
-
-2006-05-23 Carlos O'Donell <carlos@codesourcery.com>
-
- * Makefile.in: Add install-html target. Add install-html to .PHONY
-
-2006-02-21 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- PR libobjc/26309
- * thr-objc.c (_XOPEN_SOURCE): Don't define on Tru64 UNIX.
-
-2006-01-24 David Ayers <d.ayers@inode.at>
-
- PR libobjc/9751
- * gc.c (class_ivar_set_gcinvisible): Replace strncpy with memcpy
- and insure the new strings are '\0' termintated.
-
-2006-01-24 David Ayers <d.ayers@inode.at>
-
- PR libobjc/13946
- * configure.ac: Add include directives for --enable-objc-gc.
- * Makefile.in: Ditto.
- * configure: Regenerate.
-
- * gc.c (__objc_class_structure_encoding): Increment the used bytes
- instead of the local pointer to them.
-
-2005-12-14 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR objc/25360
- * objc/objc-api.c (_C_COMPLEX): New define.
- * encoding.c (objc_sizeof_type): Handle _C_Complex.
- (objc_alignof_type): Likewise.
- (objc_skip_typespec): Likewise.
-
-2005-12-15 David Ayers <d.ayers@inode.at>
-
- PR libobjc/14382
- * README (+load,+initialize): Fix documentation to reflect
- intended and implemented semantics for +load and +initialize.
-
-2005-12-12 Andrew Pinski <pinskia@physics.uc.edu>
-
- * encoding.c (TYPE_FIELDS): Fix to skip over just _C_STRUCT_B and
- the name.
- (get_inner_array_type): Fix to skip over _C_ARY_B and size.
- (rs6000_special_round_type_align): Update for the ABI fix.
- (objc_layout_finish_structure): Correct the encoding which is passed to
- ROUND_TYPE_ALIGN.
-
-2005-12-11 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/25347
- * encoding.c (objc_sizeof_type): Don't handle _C_UNION_B special
- but use the struct layout functions.
- (objc_alignof_type): Likewise.
- (objc_layout_structure): Handle _C_UNION_B also.
- (objc_layout_structure_next_member): Likewise.
- (objc_layout_finish_structure): Likewise.
-
-2005-12-11 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/25346
- * objc/objc-api.h (_C_BOOL): New define.
- * encoding.c (objc_sizeof_type): Handle _C_BOOL.
- (objc_alignof_type): Likewise.
- (objc_skip_typespec): Likewise.
-
-2005-11-20 David Ayers <d.ayers@inode.at>
-
- PR libobjc/19024
- * objc/hash.h: Remove deprecated hash API.
- * hash_compat.c: Remove.
- * Makefile.in: Remove reference to hash_compat.c.
-
- * configure.ac (VERSION): Bump library version to 2:0:0.
- * configure: Regenerate.
-
-2005-11-09 Alexandre Oliva <aoliva@redhat.com>
-
- PR other/4372
- * thr-objc.c (_XOPEN_SOURCE): Define.
-
-2005-10-07 Ulrich Weigand <uweigand@de.ibm.com>
-
- PR libobjc/23612
- * objc/objc-api.h (struct objc_ivar): Move definition to
- global scope.
-
-2005-09-04 Andrew Pinski <pinskia@physics.uc.edu>
- Rasmus Hahn <rassahah@neofonie.de>
-
- PR libobjc/23108
- * archive.c (objc_write_type): Correct the element offset.
- (objc_read_type): Likewise.
-
-2005-08-17 Kelley Cook <kcook@gcc.gnu.org>
-
- * All files: Update FSF address.
-
-2005-08-13 Marcin Koziej <creep@desk.pl>
- Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/22492
- * exception.c (PERSONALITY_FUNCTION): Fix the PC with finally.
-
-2005-08-13 Andrew Pinski <pinskia@physics.uc.edu>
-
- * Makefile.in (extra_ldflags_libobjc): New.
- (libobjc$(libext).la): Add extra_ldflags_libobjc to the link line.
- (libobjc_gc$(libext).la): Likewise.
- * configure.ac (extra_ldflags_libgfortran): Set for *-darwin* to
- "-Wl,-single_module".
- * configure: Regenerate.
- * linking.m (_objcInit): Remove.
-
-2005-07-26 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/22606
- * Makefile.in (ALL_CFLAGS): Add -fexceptions.
-
-2005-06-08 David Ayers <d.ayers@inode.at>
-
- * objc/NXConstStr.h, objc/Object.h, objc/Protocol.h,
- objc/encoding.h, objc/hash.h, objc/objc-api.h,
- objc/runtime.h, objc/sarray.h, objc/thr.h,
- objc/typedstream.h: Do not include Objective-C headers as
- system headers.
-
-2005-06-07 David Ayers <d.ayers@inode.at>
-
- * archive.c, init.c, selector.c: Include hash.h.
- * archive.c, class.c, encoding.c, gc.c, hash.c, hash_compat.c,
- init.c, misc.c, nil_method.c, objects.c, sarray.c, selector.c,
- sendmsg.c, thr-dce.c, thr-decosf1.c, thr-irix.c, thr-mach.c,
- thr-objc.c, thr-os2.c, thr-posix.c, thr-pthreads.c, thr-rtems.c,
- thr-single.c, thr-solaris.c, thr-vxworks.c, thr-win32.c, thr.c:
- Include Objective-C headers with quotes and objc/ directory
- prefix.
-
-2005-05-19 Richard Henderson <rth@redhat.com>
-
- * exception.c: Revert last change.
-
-2005-05-19 David Ayers <d.ayers@inode.at>
-
- * exception.c: Include tsystem.h for unwind.h.
-
-2005-05-09 Mike Stump <mrs@apple.com>
-
- * configure: Regenerate.
-
-2005-04-12 Mike Stump <mrs@apple.com>
-
- * configure: Regenerate.
-
-2005-03-21 Zack Weinberg <zack@codesourcery.com>
-
- * Makefile.in: Set gcc_version here.
- * configure.ac: Do not invoke TL_AC_GCC_VERSION. Adjust quoting
- in definition of toolexeclibdir so that $(gcc_version) is expanded
- by the Makefile.
- * aclocal.m4, configure: Regenerate.
-
-2005-03-03 David Ayers <d.ayers@inode.at>
-
- * objc/hash.h (OBJC_IGNORE_DEPRECATED_API): Update deprecated
- version reference. Correct typo.
-
-2005-03-02 David Ayers <d.ayers@inode.at>
-
- PR libobjc/19024
- * Makefile.in (OBJS): Add hash_compat.lo.
- (OBJS_GC): Add hash_compat_gc.lo.
- (hash_compat_gc.lo): New target and rule.
- * objc/hash.h (hash_new, hash_delete, hash_add, hash_remove)
- (hash_next, hash_value_for_key, hash_is_key_in_hash)
- (hash_ptr, hash_string, compare_ptrs, compare_strings): Prefix
- with objc_. Add deprecated non prefixed inlined versions.
- (OBJC_IGNORE_DEPRECATED_API): New macro to hide deprecated
- declarations.
- * hash.c (hash_new, hash_delete, hash_add, hash_remove, hash_next)
- (hash_value_for_key, hash_is_key_in_hash): Prefix with objc_ and
- update callers.
- * hash_compat.c: New file.
- * archive.c: Update callers.
- * init.c: Likewise.
- * selector.c: Likewise.
- * libobjc.def: Add objc_ versions of hash functions.
-
-2005-02-28 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/20252
- * Makefile.in (GTHREAD_FLAGS): Remove.
- (ALL_CFLAGS): Remove usage of GTHREAD_FLAGS.
- * thr-objc.c: Include config.h.
- * configure.ac: Instead of looking at GCC's makefile, figure out if
- GTHREAD_FLAGS should be defined by looking at the `thread model'
- of the current gcc.
- * configure: Regenerate.
- * config.h.in: Regenerate.
-
-2005-02-28 Paolo Bonzini <bonzini@gnu.org>
-
- PR bootstrap/17383
- * configure.ac: Call GCC_TOPLEV_SUBDIRS.
- (Determine CFLAGS for gthread): Use $host_subdir.
- * configure: Regenerate.
- * Makefile.in (host_subdir): New.
- (INCLUDES): Use it.
-
-2004-12-20 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/12035
- * gc.c: Remove definition of LOGWL, modWORDSZ, and divWORDSZ since
- they are not used.
- Include limits.h and stdlib.h.
- Define BITS_PER_WORD.
-
-2004-12-12 Alexander Malmberg <alexander@malmberg.org>
-
- * selector.c (__objc_init_selector_tables): Add missing void to
- definition.
-
-2004-12-02 Richard Sandiford <rsandifo@redhat.com>
-
- * configure.ac: Use TL_AC_GCC_VERSION to set gcc_version.
- * configure, aclocal.m4: Regenerate.
-
-2004-11-29 Kelley Cook <kcook@gcc.gnu.org>
-
- * configure: Regenerate for libtool change.
-
-2004-11-25 Kelley Cook <kcook@gcc.gnu.org>
-
- * configure: Regenerate for libtool reversion.
-
-2004-11-24 Kelley Cook <kcook@gcc.gnu.org>
-
- * configure: Regenerate for libtool change.
-
-2004-11-24 Kelley Cook <kcook@gcc.gnu.org>
-
- * aclocal.m4, config.h.in: Regenerate.
-
-2004-10-08 Mike Stump <mrs@apple.com>
- Andrew Pinski <pinskia@physics.uc.edu>
-
- * aclocal.m4: Rename to ...
- * acinclude.m4: here and also use m4_include instead of sinclude.
- * aclocal.m4: Regenerate.
- * configure: Regenerate.
- * configure.ac: Add AM_MAINTAINER_MODE and AM_PROG_CC_C_O.
- * Makefile.in (configure): Add @MAINT@ infront of configure.ac
-
-2004-10-08 Andrew Pinski <pinskia@physics.uc.edu>
-
- * archive.c: Fix all the warnings about passing unsigned char*
- to char* and the other way too.
-
-2004-09-16 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR libobjc/16448
- * exception.c: Include config.h
- (objc_exception_throw): Change _GLIBCXX_SJLJ_EXCEPTIONS to
- SJLJ_EXCEPTIONS.
- * configure.ac: Find out what exception handling code we use.
- * configure: Regenerate.
- * config.h.in: New file, regenerate.
-
-2004-09-16 Andrew Pinski <apinski@apple.com>
-
- * encoding.c (ALTIVEC_VECTOR_MODE): Define a bogus macro.
-
-2004-08-28 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * configure.ac: Switch from _GCC_TOPLEV_NONCANONICAL_TARGET to
- ACX_NONCANONICAL_TARGET.
- * configure: Regenerate.
-
-2004-08-13 Ziemowit Laski <zlaski@apple.com>
-
- * objc/sarray.h: Hoist include of assert.h near the top of file,
- and mark the remainder of the file 'extern "C"'.
-
-2004-08-13 Andrew Pinski <pinskia@physics.uc.edu>
-
- * objc/Object.h: Move includes out of extern "C" blocks.
- * objc/encoding.h: Likewise.
- * objc/hash.h: Likewise.
- * objc/objc-api.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc/sarray.h: Likewise.
- * objc/typedstream.h: Likewise.
-
-2004-08-12 Ziemowit Laski <zlaski@apple.com>
-
- * objc/NXConstStr.h: Update copyright date; bracket with
- 'extern "C"' for C++ use; make include syntax consistent
- by using <...> instead of "..."; hoist <objc/...> includes
- above the 'extern "C"' block.
- * objc/Object.h: Likewise.
- * objc/Protocol.h: Likewise.
- * objc/encoding.h: Likewise.
- * objc/hash.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc/sarray.h: Likewise.
- * objc/thr.h: Likewise.
- * objc/typedstream.h: Likewise.
- * objc/objc-api.h: Add 'extern "C"' block for C++ use.
- (objc_static_instances): For C++ case, do away with
- zero-sized array.
- (objc_method): Hoist definition to file scope.
- (_objc_load_callback, _objc_object_alloc, class_get_class_method,
- class_get_instance_method, class_create_instance,
- class_get_class_name, class_get_instance_size,
- class_get_meta_class, class_get_super_class, class_get_version,
- class_is_class, class_is_meta_class, class_set_version,
- class_get_gc_object_type, class_ivar_set_gcinvisible,
- get_imp): Rename 'class' parameter to '_class'.
- * objc/objc-list.h: Add 'extern "C"' block for C++ use.
- * objc/objc.h: Update copyright date.
- (arglist_t): Provide a union tag.
-
-2004-07-22 Andrew Pinski <pinskia@physics.uc.edu>
-
- * thr.c (__objc_thread_detach_function): Do not mark as volatile
- but instead use the attribute noreturn.
-
-2004-06-28 Zack Weinberg <zack@codesourcery.com>
-
- * encoding.c: Rename target_flags with a #define to avoid
- conflict with a prior declaration.
-
-2004-06-24 Andrew Pinski <apinski@apple.com>
-
- * objc/encoding.h: Wrap the functions with extern "C" for C++
- mode.
- * objc/hash.h: Likewise.
- * objc/objc-api.h: Likewise.
- * objc/objc-list.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc/sarray.h: Likewise.
- * objc/thr.h: Likewise.
- * objc/typedstream.h: Likewise.
-
-
-2004-06-21 Nick Clifton <nickc@redhat.com>
-
- * encoding.c (BITS_PER_UNIT): Define if a definition is not
- provided.
-
-2004-06-20 Alexander Malmberg <alexander@malmberg.org>
-
- * Makefile.in (exception.lo): Remove $(OBJC_GCFLAGS).
- (exception_gc.lo): New.
- (OBJS_GC): Add exception_gc.lo.
-
-2004-06-17 Richard Henderson <rth@redhat.com>
-
- * exception.c: New file.
- * Makefile.in (exception.lo): New.
- (OBJS): Add it.
-
-2004-06-14 Andrew Pinski <pinskia@physics.uc.edu>
-
- * linking.m (_objcInit): New empty function
- for Darwin only.
-
-2004-06-11 Andrew Pinski <pinskia@physics.uc.edu>
-
- * configure.ac: Support --enable-shared=libobjc.
- * configure: Regenerate.
-
- PR libobjc/15901
- * configure.ac: Do not disable shared by default.
- * configure: Regenerate.
-
-2004-06-03 Nicola Pero <n.pero@mi.flashnet.it>
-
- * Protocol.m ([-isEqual:]): Small optimizations returning
- immediately if the argument is equal to self, and accessing
- the argument's name directly if it's a protocol.
-
-2004-06-03 David Ayers <d.ayers@inode.at>
-
- * Protocol.m ([-isEqual:]): Test the class of the argument.
-
-2004-05-25 Andrew Pinski <pinskia@physics.uc.edu>
-
- * configure.ac (includedir): Rename to ...
- (includedirname).
- * Makefile.in: s/includedir/includedirname/.
-
- PR target/11572
- * configure.ac (includedir): Set to "include"
- except for Darwin.
- (libext) Set to empty except for Darwin.
- * configure: Regenerate
- * Makefile.in: s/libobjc.la/libobjc$(libext).la/g.
- s/include/$(includedir)/g.
-
-2004-05-25 Daniel Jacobowitz <drow@false.org>
-
- * Makefile.in: Add .NOEXPORT.
-
-2004-05-25 Andrew Pinski <pinskia@physics.uc.edu>
-
- Merge from the libobjc-branch
- 2004-02-09 Andrew Pinski <pinskia@physics.uc.edu>
-
- * Makefile.in (OBJC_H): Change objc-deps.h to objc-decls.h.
-
- 2004-02-03 Andrew Pinski <pinskia@physics.uc.edu>
-
- * Makefile.in (OBJC_H): Add objc-deps.h.
-
- 2004-01-27 Nicola Pero <n.pero@mi.flashnet.it>
-
- * Protocol.m ([-conformsTo:]): If the argument is nil, return NO.
- ([-hash], [-isEqual:]): New methods.
-
- 2004-01-27 Richard Frith-Macdonald <rfm@gnu.org>
-
- * sarray.c (sarray_free): Add a better comment.
-
- 2004-01-27 Adam Fedor <fedor@gnu.org>
-
- * hash.c (hash_add): Cast cachep to int.
- * selector.c (__sel_register_typed_name): Cast
- soffset_decode to int.
-
- 2004-01-27 Alexander Malmberg <alexander@malmberg.org>
-
- * selector.c: Rename register_selectors_from_list to
- __objc_register_selectors_from_list. Update caller.
- (__objc_register_selectors_from_list): Lock __objc_runtime_mutex
- while registering selectors. Use __sel_register_typed_name instead
- of sel_register_typed_name. Check for NULL method_name:s.
- (pool_alloc_selector): New function.
- (__sel_register_typed_name): Use pool_alloc_selector to allocate
- selector structures.
- * sendmsg.c (class_add_method_list): Use
- __objc_register_selectors_from_list.
- * objc/runtime.h: Add __objc_register_selectors_from_list.
-
- 2004-01-25 Adam Fedor <fedor@gnu.org>
- Nicola Pero <n.pero@mi.flashnet.it>
- Andrew Pinski <pinskia@physics.uc.edu>
-
- * objc/objc-decls.h: New file.
- * objc/objc-api.h (_objc_lookup_class): Mark as export.
- (_objc_load_callback): Likewise.
- (_objc_object_alloc): Likewise.
- (_objc_object_copy): Likewise.
- (_objc_object_dispose): Likewise.
-
- 2004-01-25 Andrew Pinski <pinskia@physics.uc.edu>
-
- * archive.c: s/__inline__/inline
- * sendmsg.c: Likewise.
-
- * encoding.c: Remove FIXME about the warning
- about unused variable.
- * sendmsg.c: Add a FIXME comment saying that
- this should be using libffi.
-
- * Makefile.in (LIBTOOL): Use @LIBTOOL@ now as it works.
-
-
-2004-05-13 Andrew Pinski <pinskia@physics.uc.edu>
-
- * archive.c (objc_read_class): Initialize class_name.
- (objc_read_selector): Initialize selector_name.
-
-2004-05-09 Richard Sandiford <rsandifo@redhat.com>
-
- * Makefile.in (toolexecdir): Remove trailing space.
-
-2004-04-15 Nathanael Nerode <neroden@gcc.gnu.org>
-
- PR libobjc/14948
- * configure.ac: De-precious CC so multilibs work.
- * configure: Regenerate.
-
-2004-04-14 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * configure.ac: Restore toolexecdir.
- * Makefile.in: Restore toolexecdir.
- * configure: Regenerate.
-
-2004-04-09 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * configure.ac: Remove (unused) glibcpp_prefixdir.
- * configure: Regenerate.
-
- * configure.in: Rename to configure.ac.
- * Makefile.in: Update to match.
-
- * Makefile.in: Remove toolexecdir, glibcpp_toolexecdir (unused).
- Replace glibcpp_toolexeclibdir with toolexeclibdir.
- * configure.in: Remove glibcpp_toolexecdir (unused).
- Replace glibcpp_toolexeclibdir with toolexeclibdir. Don't generate
- config.h or stamp-h (unused). Move one comment to the right place.
- * configure: Regenerate.
- * config.h.in: Remove (unused).
-
- * config.h.in: Regenerate with autoheader.
-
- * Makefile.in: Remove (unused) gcc_version_trigger.
- * configure.in: Remove (unused) glibcpp_builddir. Don't AC_SUBST
- gcc_version_trigger.
- * configure: Regenerate.
-
- * configure.in: Switch to modern style for AC_INIT, AC_OUTPUT.
- Sort file into sections. Remove dnl where appropriate. Fix
- other style issues.
- * configure: Regenerate.
-
- * configure.in: Replace old AC_PROG_CC hack with new one.
- Define toplevel_srcdir in terms of srcdir, not top_srcdir (there
- are no subdirectory output files, so this is fine). Change prereq
- to autoconf 2.59.
- * aclocal.m4: Include ../config/no-executables.m4.
- * configure: Regenerate with autoconf 2.59.
-
- * configure.in: Improve comments on gthread_cflags. Improve m4
- quotation, and replace 'if test' with 'case', for --enable-objc-gc.
- * configure: Regenerate.
-
- * configure.in: Move PACKAGE and VERSION settings up top. Remove
- unused call to AC_PROG_LN_S. Default RANLIB to ':'. Remove
- redundant checks for values of RANLIB, AR, INSTALL.
- * configure: Regenerate.
-
- * configure.in: Clean up handling of
- --enable-version-specific-runtime-libs and related variables;
- replace 'if test' with 'case' where reasonable. Fix comments.
- Remove useless libstdcxx_interface.
- * configure: Regenerate.
-
- * configure.in: Use _GCC_TOPLEV_NONCANONICAL_TARGET.
- Replace uses of target_alias with target_noncanonical.
- * aclocal.m4: Include ../config/acx.m4.
- * configure: Regenerate.
- * Makefile.in: Replace uses of target_alias with target_noncanonical.
- Fix copyright statement.
-
- * configure.in: Hand-inline bulky, confusing macros from
- aclocal.m4. Replace references to "GNU Objective C" with "GCC".
- Update copyright notice. Remove stuff for automake, which isn't
- used in this directory. Remove emacs local variables.
- * aclocal.m4: Remove hand-inlined macros. Update copyright notice.
- * configure: Regenerate.
-
-2004-03-16 Manfred Hollstein <mh@suse.com>
-
- * Makefile.in, configure.in, configure: Update copyright years.
-
-2004-03-15 Manfred Hollstein <mh@suse.com>
-
- * Makefile.in (LIBOBJC_VERSION, LIBOBJC_GC_VERSION): Use
- definition from configure.in.
- * configure.in (PACKAGE): Add definition.
- (VERSION): Add definition; substitute it in output files.
- * configure: Re-generate.
-
-2004-03-05 Ziemowit Laski <zlaski@apple.com>
-
- * objc/hash.h (hash_string, compare_strings):
- Add type-casts to make Objective-C++ happy.
- * objc/typedstream.h (objc_get_stream_class_version):
- Rename parameter from 'class' to 'class_name' to make
- Objective-C++ happy.
-
-2004-03-01 Michael Matz <matz@suse.de>
-
- * Makefile.in (ALL_CFLAGS): Add -fno-strict-aliasing.
-
-2004-02-06 Ziemowit Laski <zlaski@apple.com>
-
- * objc/objc-api.h (objc_super): The 'class' field shall
- be named 'super_class' #ifdef __cplusplus.
-
-2004-01-17 Andrew Pinski <pinskia@physics.uc.edu>
-
- PR target/10781
- * encoding.c (rs6000_special_round_type_align): Define.
-
-2004-01-14 Adam Fedor <fedor@gnu.org>
-
- PR libobjc/12155
- * selector.c (__objc_register_instance_methods_to_class): Free
- new_list if not used.
-
-2004-01-09 Andrew Ruder <aeruder@ksu.edu>
-
- PR libobjc/11904
- * sarray.c (sarray_free): Free array->is_copy_of latter.
-
-2003-12-01 Zack Weinberg <zack@codesourcery.com>
-
- PR 11433
- * Protocol.m (descriptionForInstanceMethod): Don't dereference
- instance_methods if it's NULL.
- (descriptionForClassMethod): Likewise for class_methods.
-
-2003-10-24 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Makefile.in (runtime-info.h): Remove -Wp.
-
-2003-10-21 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Makefile.in (CC1OBJ): Remove.
- (runtime-info.h): Invoke $(CC) so all MULTIFLAGS are handled
- correctly.
- Use .m extension for temporary file.
- Remove assembler temp file.
-
-2003-10-20 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * objc/hash.h (hash_string): Don't use a cast as an lvalue.
-
-2003-10-17 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Makefile.in (runtime-info.h): Use MULTIFLAGS.
-
-2003-09-09 Alan Modra <amodra@bigpond.net.au>
-
- * configure: Regenerate.
-
-2003-08-27 Alexander Malmberg <alexander@malmberg.org>
-
- * Makefile.in, aclocal.m4: Update to $(libdir)/gcc/ instead of
- (libdir)/gcc-lib/ when installing.
- * configure: Regenerate.
-
-Thu Jul 10 10:27:43 2003 Nicola Pero <n.pero@mi.flashnet.it>
-
- libobjc/9969
- * sendmsg.c (get_imp): Fixed rare threading problem.
- (__objc_responds_to): Similar fixes.
- (objc_msg_lookup): Similar fixes.
- (__objc_init_install_dtable): Lock the runtime before checking if the
- table is installed.
-
-2003-05-23 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * hash.c, init.c, libobjc.def, libobjc_entry.c, linking.m,
- makefile.dos, misc.c, nil_method.c, objects.c, sarray.c,
- selector.c, sendmsg.c, thr-dce.c, thr-decosf1.c, thr-irix.c,
- thr-mach.c, thr-objc.c, thr-os2.c, thr-posix.c, thr-pthreads.c,
- thr-rtems.c, thr-single.c, thr-solaris.c, thr-vxworks.c,
- thr-win32.c, thr.c: Replace "GNU CC" with "GCC".
- * Makefile.in, NXConstStr.m, Object.m, Protocol.m, archive.c,
- class.c, encoding.c, gc.c, objc/NXConstStr.h, objc/Object.h,
- objc/Protocol.h, objc/encoding.h, objc/hash.h, objc/objc-api.h,
- objc/objc-list.h, objc/objc.h, ocjc/runtime.h, objc/sarray.h,
- objc/thr.h, objc/typedstream.h: Replace "GNU CC" with "GCC".
-
-Tue May 13 14:56:03 2003 Richard Frith-Macdonald <rfm@gnu.org>
- Nicola Pero <n.pero@mi.flashnet.it>
-
- libobjc/10742
- * init.c (class_superclass_of_class): New function.
- (create_tree_of_subclasses_inherited_from): Use it.
- (__objc_tree_insert_class): Likewise.
- (class_is_subclass_of_class): Likewise.
-
-2003-04-11 David Chad <davidc@freebsd.org>
- Loren J. Rittle <ljrittle@acm.org>
-
- libobjc/8562
- * objc/hash.h (hash_string): Constify correctly.
- (compare_ptrs): Use direct compare.
- * objc/objc-list.h (list_nth): Rename index to indx to avoid shadow.
- * objc/sarray.h: Global rename index to indx to avoid shadow.
-
-2003-03-12 Andreas Schwab <schwab@suse.de>
-
- * aclocal.m4 (GLIBCPP_EXPORT_INSTALL_INFO): Avoid trailing /. in
- glibcpp_toolexeclibdir.
- * configure: Rebuilt.
-
-2003-02-20 Alexandre Oliva <aoliva@redhat.com>
-
- * configure.in: Propagate ORIGINAL_LD_FOR_MULTILIBS to
- config.status.
- * configure: Rebuilt.
-
-2003-01-27 Alexandre Oliva <aoliva@redhat.com>
-
- * aclocal.m4 (glibcpp_toolexeclibdir): Instead of
- $(MULTISUBDIR), use `$CC -print-multi-os-directory`, unless
- version_specific_libs is enabled.
- * configure: Rebuilt.
-
-2003-01-09 Christian Cornelssen <ccorn@cs.tu-berlin.de>
-
- * Makefile.in (FLAGS_TO_PASS): Also pass DESTDIR.
- (install-libs, install-headers): Prepend $(DESTDIR) to
- destination paths in all (un)installation commands.
-
-2002-12-02 Zack Weinberg <zack@codesourcery.com>
-
- * thr-objc.c: Include coretypes.h and tm.h.
-
-2002-12-01 Zack Weinberg <zack@codesourcery.com>
-
- * encoding.c, sendmsg.c: Include coretypes.h and tm.h.
-
-2002-11-26 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * configure.in: Remove skip-this-dir support.
- * configure: Regenerate.
-
-2002-09-22 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (all): Fix multilib parallel build.
-
-Thu Sep 12 12:44:37 2002 Nicola Pero <n.pero@mi.flashnet.it>
-
- * sendmsg.c (nil_method): Declare not to take a variable number of
- args.
- (objc_msg_lookup): Cast nil_method to IMP before returning it.
- (objc_msg_lookup_super): The same.
-
-2002-09-10 Jan Hubicka <jh@suse.cz>
-
- * nil_method.c (nil_method): No longer defined with variable
- arguments.
-
-2002-07-02 Rodney Brown <rbrown64@csc.com.au>
-
- * objc/encoding.h: Fix formatting.
- * objc/hash.h: Likewise.
- * objc/objc-api.h: Likewise.
- * objc/runtime.h: Likewise.
- * objc/thr.h: Likewise.
- * archive.c: Likewise.
- * class.c: Likewise.
- * encoding.c: Likewise.
- * gc.c: Likewise.
- * hash.c: Likewise.
- * init.c: Likewise.
- * misc.c: Likewise.
- * nil_method.c: Likewise.
- * objects.c: Likewise.
- * sarray.c: Likewise.
- * selector.c: Likewise.
- * sendmsg.c: Likewise.
- * thr-mach.c: Likewise.
- * thr.c: Likewise.
-
-2002-06-25 DJ Delorie <dj@redhat.com>
-
- * aclocal.m4 (GLIBCPP_CONFIGURE): Split out
- GLIBCPP_TOPREL_CONFIGURE.
- * configure.in: Call it before AC_CANONICAL_SYSTEM.
- * configure: Regenerate.
-
-2002-06-21 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Object.m (forward, read, write): Fix unused parameter warnings.
- * encoding.c: Include <stdlib.h>.
- (target_flags): Mark with attribute unused.
- (atoi): Delete.
- * runtime.h (__objc_selector_max_index): Change to unsigned int.
- (__objc_generate_gc_type_description): Prototype.
- * selector.c (__objc_selector_max_index): Change to unsigned int.
-
-Mon Jun 17 18:37:42 2002 Nicola Pero <n.pero@mi.flashnet.it>
-
- * sendmsg.c (__objc_get_forward_imp): Fix warning by making sure
- we always have a return value: if __objc_msg_forward does not
- supply a forwarding implementation, return the default
- __builtin_apply based one.
-
-2002-06-15 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Object.m: Fix signed/unsigned warning.
- * Protocol.m: Likewise.
- * archive.c: Always include stdlib.h.
- (objc_read_short, objc_read_unsigned_short, objc_read_int,
- objc_read_long, __objc_read_nbyte_uint, __objc_read_nbyte_ulong):
- Fix signed/unsigned warning.
- (objc_write_type, objc_read_type, objc_write_types,
- objc_read_types): Ensure ctype 8-bit safety.
- (__objc_no_write, __objc_no_read): Mark unused parameters.
- * class.c (class_table_setup): Specify void arg.
- * encoding.c (atoi, objc_sizeof_type, objc_alignof_type,
- objc_skip_typespec, objc_skip_offset,
- objc_layout_structure_next_member): Ensure ctype 8-bit safety.
- (objc_layout_structure_next_member): Ensure variables are
- initialized.
- * gc.c (__objc_generate_gc_type_description,
- class_ivar_set_gcinvisible): Mark unused parameters.
- * init.c (__objc_send_load, __objc_destroy_class_tree_node): Mark
- unused parameters.
- (__objc_init_protocols) Fix signed/unsigned warning.
- * nil_method.c (nil_method): Mark unused parameters.
- * thr.h (objc_thread_callback): Specify void arg.
- * sarray.c (sarray_new, sarray_realloc, sarray_free): Fix
- signed/unsigned warning.
- (sarray_free): Fix formatting.
- * selector.c (sel_types_match): Ensure ctype 8-bit safety.
- * sendmsg.c (__objc_init_install_dtable) Mark unused parameters.
-
-2002-06-09 Andreas Jaeger <aj@suse.de>
-
- * encoding.c (objc_layout_structure_next_member): Remove unused
- variable.
-
-2002-05-20 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (SHELL): Set to @SHELL@.
- (WARN_CFLAGS): New.
- (ALL_CFLAGS): Add $(WARN_CFLAGS).
-
-2002-05-16 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * aclocal.m4: Allow for PWDCMD to override hardcoded pwd.
- * configure: Regenerate.
-
-2002-05-08 Alexandre Oliva <aoliva@redhat.com>
-
- * configure.in (ORIGINAL_LD_FOR_MULTILIBS): Preserve LD at
- script entry, and set LD to it when configuring multilibs.
- * configure: Rebuilt.
-
-2002-04-19 David O'Brien <obrien@FreeBSD.org>
-
- * encoding.c (MAX, MIN, ROUNDING): #undef before defining.
-
-2002-04-09 Hans-Peter Nilsson <hp@bitrange.com>
-
- PR objc/6107
- * objc/objc-api.h (struct objc_protocol_list): Change type of
- member count from int to size_t.
-
-2002-02-11 Franz Sirl <Franz.Sirl-kernel@lauterbach.com>
-
- PR libobjc/4039
- * aclocal.m4: Replace with version copied from libstdc++-v3.
- * configure.in: Update for changes to aclocal and Makefile.
- * configure: Regenerate.
- * Makefile.in: Correct install of multilibs and shared libs, use
- INSTALL_DATA for include files.
-
-Mon Dec 17 17:02:12 2001 Nicola Pero <nicola@brainstorm.co.uk>
-
- * init.c (__objc_exec_class): Fixed bug in the loop on unclaimed
- categories - when an unclaimed category was found, the loop was
- doing two steps forward instead of one, so that in certain cases
- it was failing to properly load all the categories. (Reported
- with fix by Alexander Malmberg <alexander@malmberg.org>).
-
-2001-11-14 Aldy Hernandez <aldyh@redhat.com>
-
- * encoding.c: Add target_flags.
-
-2001-11-07 Aldy Hernandez <aldyh@redhat.com>
-
- * objc/objc-api.h (_C_VECTOR): New.
-
- * encoding.c (VECTOR_TYPE): New.
-
-Mon Oct 29 21:29:21 2001 Nicola Pero <n.pero@mi.flashnet.it>
-
- * class.c: Rewritten the class table to use optimized, lock-free
- lookup. This more than doubles the speed of class method
- invocations. (class_table_setup), (class_table_insert),
- (class_table_replace), (class_table_get_safe),
- (class_table_next), (class_table_print),
- (class_table_print_histogram): New functions.
- (__objc_init_class_tables): Use class_table_setup.
- (__objc_add_class_to_hash): Use class_table_get_safe and
- class_table_insert. (objc_lookup_class), (objc_get_class): Do not
- assert the existence of the table; do not lock the runtime; use
- class_table_get_safe. (objc_next_class): Use class_table_next.
- (__objc_resolve_class_links): Use class_table_next.
- (class_pose_as): Use class_table_replace.
-
-2001-09-10 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * gc.c: Removed the DEBUG declaration.
-
-Wed Jul 18 12:48:56 2001 Nicola Pero <n.pero@mi.flashnet.it>
-
- * thr.c (objc_mutex_lock): Invoke __objc_thread_id directly,
- rather than through objc_thread_id, to save a function call.
- (objc_mutex_trylock, objc_mutex_unlock, objc_condition_wait):
- Ditto.
-
-Mon Jul 16 12:15:00 2001 Nicola Pero <n.pero@mi.flashnet.it>
-
- * objc/objc-api.h (object_is_class): Fixed - buggy code was trying
- to cast an id to a Class, which can not be done. Make the check
- by using CLS_ISMETA on the class pointer instead.
- (object_is_meta_class): Similar fix.
-
-2001-06-09 Alexandre Oliva <aoliva@redhat.com>, Stephen L Moshier <moshier@mediaone.net>
-
- * configure.in (AC_EXEEXT): Work around in case it expands to
- nothing, as in autoconf 2.50.
- * acinclude.m4: Likewise.
- * configure: Rebuilt.
-
-2001-06-08 Nicola Pero <n.pero@mi.flashnet.it>
-
- * THREADS: Explain that when we compile libobjc inside GCC, we
- always use thr-objc.c as a backend, which uses GCC's thread code.
-
-2001-06-06 Richard Frith-Macdonald <rrfm@gnu.org>
-
- * init.c (__objc_send_message_in_list): When setting a new entry
- in __objc_load_methods use the method IMP as key, but check to see
- if the method is in the hashtable by looking at the IMP also.
- Also ... call the method after adding it to the hashtable rather
- than before ... thus preventing an obscure possibility of infinite
- recursion if a +load method itself loads a subclass.
-
-2001-05-25 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * init.c (__objc_send_message_in_list): When setting a new entry
- in __objc_load_methods use the method name as key, not the method
- IMP (reported by Richard Frith-Macdonald <richard@brainstorm.co.uk>).
-
-2001-05-09 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * objc-features.texi: Move to ../gcc/objc.texi.
- * fdl.texi: Remove.
- * Makefile.in: Don't generate documentation from
- objc-features.texi.
-
-2001-05-01 Mark Mitchell <mark@codesourcery.com>
-
- * fdl.texi: New file.
- * objc-features.texi: Simplify.
- * Makefile.in: Adjust accordingly.
-
-2001-04-30 Mark Mitchell <mark@codesourcery.com>
-
- * objc-features.texi: Use the GFDL.
-
-Wed Mar 21 04:44:58 EST 2001 John Wehle (john@feith.com)
-
- * encoding.c (REAL_TYPE): Define.
-
-2001-03-19 David Edelsohn <edelsohn@gnu.org>
-
- * encoding.c (TYPE_MODE): Define.
-
-2001-03-14 Nicola Pero <n.pero@mi.flashnet.it>
-
- * thr.c (objc_thread_add): New function.
- (objc_thread_remove): Ditto.
- * objc/thr.h: Declare them.
- * libobjc.def: Mention them.
-
-2001-02-28 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * objc-features.texi: Document the @compatibility_alias compiler
- directive (description from Nicola Pero <n.pero@mi.flashnet.it>).
-
-Fri Feb 23 18:12:00 2001 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * sendmsg.c (__objc_forward): Delete strlen() declaration.
-
-2001-02-08 Geoffrey Keating <geoffk@redhat.com>
-
- * configure.in: Don't run AC_PROG_CC_WORKS or AC_EXEEXT, because
- we're not interested in the result and they might fail.
- * configure: Regenerated.
-
-2001-01-12 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * objc-features.texi: Use @email.
-
-2001-01-12 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * sendmsg.c (__objc_print_dtable_stats): Don't use #ifdef inside
- printf.
-
-2000-01-11 Richard Earnshaw <rearnsha@arm.com>
-
- * encoding.c (STRUCTURE_SIZE_BOUNDARY): Redefine in a way that
- determines the value dynamically.
-
-Wed Jan 3 00:49:10 2001 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * sendmsg.c: Added __objc_msg_forward, a hook that allows external
- libraries to provide a function that returns the real forwarding
- function. This can alleviate problems __builtin_apply() and
- friends have on various platforms. (Solution suggested by Helge
- Hess.)
-
- * objc/objc-api.h: Define __objc_msg_forward.
-
- * sendmsg.c: Define gen_rtx_REG.
-
-2000-12-06 Ralf Corsepius <corsepiu@faw.uni-ulm.de>
-
- * thr-rtems.c: New file. Stub to compile.
-
-2000-09-06 Alexandre Oliva <aoliva@redhat.com>
-
- * configure: Rebuilt with new libtool.m4.
-
-Tue Aug 15 00:38:56 2000 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * configure.in: Create a config.h file. Check for <sched.h>.
- * configure: Regenerate.
-
- * config.h.in: Check for <sched.h>.
-
-2000-08-14 Zack Weinberg <zack@wolery.cumb.org>
-
- * configure: Regenerate after change to ../libtool.m4.
-
-2000-08-14 Andreas Schwab <schwab@suse.de>
-
- * objc-features.texi (Top): Move @menu at end of node.
-
-2000-08-11 Manfred Hollstein <manfredh@redhat.com>
-
- * objc-features.texi: Move @node Top before @menu.
-
-Sun Aug 6 23:27:49 2000 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * objc-features.texi: Documented the new -fconstant-string-class
- option.
-
-Sun Aug 6 22:51:16 2000 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * thr-posix.c: Integrated Chris Ball's <cball@fmco.com> changes to
- improve the Posix thread support for Objective-C.
-
-2000-08-04 Zack Weinberg <zack@wolery.cumb.org>
-
- * aclocal.m4: Replace copy of ../libtool.m4 with
- sinclude(../libtool.m4).
-
-Fri Jul 28 08:58:02 2000 Nicola Pero <nicola@brainstorm.co.uk>
-
- * configure.in: Added libtool support; build shared libraries
- if --enable-shared was passed on command line.
- * Makefile.in: Modified most compilation commands to use libtool.
- * aclocal.m4: New symbolic link to the ../libtool.m4, from the
- libtool distribution.
-
-Sat Jul 29 00:10:21 2000 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * sarray.c, Object.m: Removed the explicit prototypes for strlen
- and memcpy on 64-bit platforms (Suggested by Rodney Brown
- <rdb@cup.hp.com>).
-
-2000-05-12 H.J. Lu (hjl@gnu.org)
-
- * Makefile.in (GTHREAD_FLAGS): New.
- (ALL_CFLAGS): Add $(GTHREAD_FLAGS).
- (OBJC_THREAD_FILE): Changed to thr-objc.
-
- * configure.in (GTHREAD_FLAGS): New, check and replace it for
- Makefile.
- (OBJC_THREAD_FILE): Removed.
-
- * thr-objc.c: New.
-
-2000-07-13 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * objc/hash.h: Include string.h.
-
-2000-04-15 David Edelsohn <edelsohn@gnu.org>
-
- * Object.m (strlen): 64-bit PowerPC is a 64bit platform as well.
-
-2000-04-12 Jakub Jelinek <jakub@redhat.com>
-
- * Object.m (strlen): Provide prototype on all 64bit platforms,
- not only alpha.
- * sarray.c (memcpy): Likewise.
- * encoding.c (objc_layout_finish_structure): Don't use
- ROUND_TYPE_ALIGN on sparc.
-
- * encoding.c (objc_layout_structure_next_member): Do the whole
- procedure even for the first member, so that we get correct
- alignment.
-
-2000-03-29 Zack Weinberg <zack@wolery.cumb.org>
-
- * objc/Protocol.h, objc/objc-list.h: Change #endif labels to
- comments.
-
-2000-02-23 Zack Weinberg <zack@wolery.cumb.org>
-
- * Makefile.in: Add -DIN_TARGET_LIBS to ALL_CFLAGS.
-
-Thu Sep 23 07:19:12 1999 Chris Ball <cball@fmco.com>
-
- * thr-posix.c (__objc_mutex_deallocate): made deallocate work.
-
-Tue Sep 21 07:47:10 1999 Jeffrey A Law (law@cygnus.com)
-
- * Makefile.in (gc.o, gc_gc.o): Do not pass -fgnu-runtime to
- the compiler when building C code.
-
-Fri Aug 6 23:32:29 1999 Daniel Jacobowitz <drow@drow.them.org>
-
- * Makefile.in (FLAGS_TO_PASS): Include prefix, exec_prefix,
- libdir, libsubdir and tooldir.
-
-Mon Jun 21 05:40:15 1999 John David Anglin <dave@hiauly1>
-
- * init.c (__objc_force_linking): Make global.
-
-Thu May 20 03:20:59 1999 Jeffrey A Law (law@cygnus.com)
-
- * configure.in (AC_EXEEXT): Remove call.
- (compiler_name): Explicitly check with no extension and .exe
- extension.
- * configure: Regenerate.
-
-Sun Apr 25 01:15:34 1999 Mumit Khan <khan@xraylith.wisc.edu>
-
- * Makefile.in (CC1OBJ): Define in terms of CC.
- (runtime-info.h): Use.
-
-Fri April 8 08:21:07 1999 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * objc-features.texi: Updated the URL to Boehm's GC page.
-
-Fri Mar 26 23:41:07 1999 Ovidiu Predescu <ovidiu@cup.hp.com>
-
- * archive.c (__objc_code_char, __objc_write_char): Explicitly specify
- the char as being signed (patch from Daniel Jacobowitz
- <drow@false.org>).
-
-Wed Mar 24 22:41:28 1999 Mumit Khan <khan@xraylith.wisc.edu>
-
- * configure.in (AC_PREREQ): Update to 2.13.
- (AC_EXEEXT): Call to find possible file extension.
- (compiler_name): Use.
- * configure: Regenerate.
-
-Wed Jan 27 02:31:01 1999 Jeffrey A Law (law@cygnus.com)
-
- * Makefile.in (ALL_CFLAGS): Add -DIN_GCC.
-
-Tue Jan 5 01:38:53 1999 Jeffrey A Law (law@cygnus.com)
-
- * configure.in (thread_file): Correct and simplify code to find
- the thread file.
- * configure: Rebuilt.
-
-1998-11-26 Manfred Hollstein <manfred@s-direktnet.de>
-
- * configure.in (compiler_name): Add check to detect if this
- language's compiler has been built.
- * configure: Regenerate.
-
-Mon Nov 23 16:50:28 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * configure.in: Use AC_PREREQ(2.12.1).
-
-Thu Nov 19 20:33:37 1998 Jeffrey A Law (law@cygnus.com)
-
- * Makefile.in (runtime-info.h): Avoid GNU make extensions.
-
-Sun Nov 8 17:46:14 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (INCLUDES): Add -I$(srcdir)/$(MULTISRCTOP)../include.
-
-Thu Oct 22 14:34:06 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * configure.in: Use AC_CONFIG_AUX_DIR($topsrcdir).
-
-Sat Oct 17 05:21:31 1998 Ovidiu Predescu <ovidiu@slip.net>
-
- * objc-features.texi (Top): Changed the email address.
- * objc-features.texi (Garbage Collection): Use @uref instead of @url.
-
-Mon Oct 11 21:25:27 1998 Ovidiu Predescu <ovidiu@slip.net>
-
- * encoding.c: Redefine get_inner_array_type to get the first entry
- in the structure.
-
-Thu Oct 8 12:21:14 1998 Richard Frith-Macdonald <richard@brainstorm.co.uk>
-
- * encoding.c (objc_skip_type_qualifiers): Handle _C_BYREF.
- (objc_get_type_qualifiers): Similarly.
- * objc/encoding.h (_C_BYREF): Define.
- (_F_BYREF): Define.
-
-1998-10-07 David S. Miller <davem@pierdol.cobaltmicro.com>
-
- * objc/sarray.h: Make boffset be an unsigned long when sparc so it
- works out on 64-bit systems.
-
-Tue Oct 6 20:32:06 1998 Alexandre Oliva <oliva@dcc.unicamp.br>
-
- * Makefile.in (INCLUDES): Make it multilib-friendly.
-
-Fri Oct 2 07:12:14 1998 H.J. Lu (hjl@gnu.org)
-
- * Makefile.in (INCLUDES): Add -I$(srcdir)/../gcc.
-
-Thu Oct 1 22:33:03 1998 Robert Lipe <robertl@dgii.com>
- Jeffrey A Law (law@cygnus.com)
-
- * Makefile.in (INCLUDES): Reference gcc via $MULTIBUILDTOP.
- (FLAGS_TO_PASS): Added.
- (runtime-info.h): Reference cc1ibj via $MULTIBUILDTOP.
-
- * archive.c: Change config.h to tconfig.h.
-
- * configure.in: Find gcc's object directory even for multilibs.
-
-Wed Sep 30 18:17:17 1998 Robert Lipe <robertl@dgii.com>
-
- * configure.in: Escape ^ in grep string.
- * configure: Rebuilt.
-
-Wed Sep 30 09:14:52 1998 Jeffrey A Law (law@cygnus.com)
-
- * All .h files pushed down into the objc/ subdirectory.
- * Makefile.in (copy_headers): Corresponding changes.
- * configure.in (AC_INIT): Corresponding changes.
- * configure: Rebuilt.
-
-1998-09-30 Ben Elliston <bje@cygnus.com>
- Jeff Law <law@cygnus.com>
-
- * Makefile.in: Rewrite.
-
- * configure.in: Likewise.
-
- * configure: Regenerate.
-
- * All .c files. Remove "objc" prefix when including objc header
- files. Include tconfig.h, not ../tconfig.h.
-
-Mon Sep 21 23:27:10 1998 Ovidiu Predescu <ovidiu@slip.net>
-
- * encoding.c (TREE_TYPE, ARRAY_TYPE): Define.
- (get_inner_array_type): Define.
-
-1998-09-21 Ben Elliston <bje@cygnus.com>
-
- * New directory. Moved files from ../gcc/objc.
-
-Copyright (C) 1998-2022 Free Software Foundation, Inc.
-
-Copying and distribution of this file, with or without modification,
-are permitted in any medium without royalty provided the copyright
-notice and this notice are preserved.
diff --git a/libgcobol/Makefile.in b/libgcobol/Makefile.in
index 7416f4906f19..277a58c1b8c1 100644
--- a/libgcobol/Makefile.in
+++ b/libgcobol/Makefile.in
@@ -1,4 +1,5 @@
# Makefile for the GCOBOL runtime library.
+# Makefile for the GCOBOL runtime library.
# Copyright (C) 1993-2022 Free Software Foundation, Inc.
# Modifications made by the Symas Corporation, 2022
@@ -19,7 +20,7 @@
#along with GCC; see the file COPYING3. If not see
#<http://www.gnu.org/licenses/>.
-#This was cribbed from the libchill, libiberty, libstdc++, and lib.objc
+#This was cribbed from the libchill, libiberty, libstdc++, and libobjc
#Makefile.in files. Some of this stuff may be unnecessary and
#worthless.
@@ -75,18 +76,17 @@ RANLIB = @RANLIB@
CC = @CC@
CFLAGS = @CFLAGS@
XCFLAGS = @XCFLAGS@
-WARN_CFLAGS = -W -Wall -Wwrite-strings -Wstrict-prototypes
+WARN_CFLAGS = -W -Wall -Wwrite-strings # -Wstrict-prototypes
ALL_CFLAGS = -I. -I$(srcdir) $(CPPFLAGS) $(DEFS) \
$(XCFLAGS) $(CFLAGS) $(WARN_CFLAGS) \
-DIN_GCC -DIN_TARGET_LIBS -fno-strict-aliasing -fexceptions
# Libtool
-# The following strings describe the version of the obj-C library
+# The following strings describe the version of the COBOL library
# begin compiled and compatibility issues.
# Please refer to Libtool documentation about how to manage these
# numbers.
LIBGCOBOL_VERSION = @VERSION@
-LIBGCOBOL_GC_VERSION = @VERSION@
LIBTOOL = @LIBTOOL@ $(LIBTOOLFLAGS)
LIBTOOL_COMPILE = $(LIBTOOL) --mode=compile
LIBTOOL_LINK = $(LIBTOOL) --mode=link
@@ -94,77 +94,34 @@ LIBTOOL_INSTALL = $(LIBTOOL) --mode=install
LIBTOOL_CLEAN = $(LIBTOOL) --mode=clean
#LIBTOOL_UNINSTALL = $(LIBTOOL) --mode=uninstall
-OBJC_GCFLAGS=@OBJC_GCFLAGS@
-OBJC_BOEHM_GC=@OBJC_BOEHM_GC@
-OBJC_BOEHM_GC_INCLUDES=@OBJC_BOEHM_GC_INCLUDES@
-OBJC_BOEHM_GC_LIBS=@OBJC_BOEHM_GC_LIBS@
-
-INCLUDES = -I$(srcdir)/$(MULTISRCTOP)../gcc \
- -I$(srcdir)/$(MULTISRCTOP)../gcc/config \
- -I$(MULTIBUILDTOP)../../$(host_subdir)/gcc \
- -I$(srcdir)/$(MULTISRCTOP)../libgcc \
- -I$(MULTIBUILDTOP)../libgcc \
- -I$(srcdir)/$(MULTISRCTOP)../include \
- $(OBJC_BOEHM_GC_INCLUDES)
+INCLUDES = \
+ -I/usr/include/c++/11 \
+ -I/usr/include/x86_64-linux-gnu/c++/11 \
+ -I$(srcdir)/$(MULTISRCTOP)../gcc/cobol \
+ $(END)
##
## The list of header/source files
##
-# User-visible header files, from the objc/ directory
-OBJC_H = \
- objc.h \
- objc-exception.h \
- objc-sync.h \
- \
- NXConstStr.h \
- Object.h \
- Protocol.h \
- message.h \
- objc-decls.h \
- runtime.h \
- thr.h
-
-# Objective-C source files to compile
-OBJC_SOURCE_FILES = \
- NXConstStr.m \
- Object.m \
- Protocol.m \
- accessors.m \
- linking.m
+# User-visible header files, from the gcobol/ directory
+GCOBOL_H = \
+ $(END)
# C source files to compile
C_SOURCE_FILES = \
- class.c \
- encoding.c \
- error.c \
- gc.c \
- hash.c \
- init.c \
- ivars.c \
- memory.c \
- methods.c \
- nil_method.c \
- objc-foreach.c \
- objc-sync.c \
- objects.c \
- protocols.c \
- sarray.c \
- selector.c \
- sendmsg.c \
- thr.c \
- exception.c
+ charmaps.cc \
+ gfileio.cc \
+ gmath.cc \
+ intrinsic.cc \
+ io.cc \
+ libgcobol.cc \
+ $(END)
# Object files to link (when the library is linked with no GC (Garbage Collection))
OBJS = \
- $(patsubst %.m,%.lo,$(OBJC_SOURCE_FILES)) \
- $(patsubst %.c,%.lo,$(C_SOURCE_FILES))
-
-# Object files to link (when the library is linked with GC (Garbage Collection))
-OBJS_GC = \
- $(patsubst %.m,%_gc.lo,$(OBJC_SOURCE_FILES)) \
- $(patsubst %.c,%_gc.lo,$(C_SOURCE_FILES))
-
+ $(patsubst %.c,%.lo,$(C_SOURCE_FILES)) \
+ $(patsubst %.cc,%.lo,$(C_SOURCE_FILES))
##
## The rules to build
@@ -197,62 +154,26 @@ FLAGS_TO_PASS = \
# The 'all' rule must be the first one so that it is executed if
# nothing is specified on the command-line.
-all: libgcobol$(libsuffix).la $(OBJC_BOEHM_GC)
+all: libgcobol$(libsuffix).la
: $(MAKE) ; exec $(MULTIDO) $(FLAGS_TO_PASS) multi-do DO=all
.SUFFIXES:
-.SUFFIXES: .c .m .lo
+.SUFFIXES: .c .lo .cc
%.lo: %.c
$(LIBTOOL_COMPILE) $(CC) $< -c \
$(ALL_CFLAGS) $(INCLUDES) \
-o $@
-%_gc.lo: %.c
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) $(OBJC_GCFLAGS) \
- -o $@
-
-%.lo: %.m
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) -fgnu-runtime \
- -o $@
-
-%_gc.lo: %.m
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) $(OBJC_GCFLAGS) -fgnu-runtime \
- -o $@
-
-# sendmsg has a special rule because it depends on runtime-info.h.
-runtime-info.h:
- echo "" > tmp-runtime.m
- echo "/* This file is automatically generated */" > $@
- $(CC) $(MULTIFLAGS) -print-objc-runtime-info -S tmp-runtime.m >> $@
- rm -f tmp-runtime.m tmp-runtime.s
-
-sendmsg.lo: sendmsg.c runtime-info.h
+%.lo: %.cc
+ echo "DUBNER SAYS ABOUT TO COMPILE<<<<<<<<<<<<<<<<<<<<<<<<<<"
$(LIBTOOL_COMPILE) $(CC) $< -c \
$(ALL_CFLAGS) $(INCLUDES) \
-o $@
-sendmsg_gc.lo: sendmsg.c runtime-info.h
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) $(OBJC_GCFLAGS) \
- -o $@
-
# These files have separate rules because they require special
# compiler flags.
-exception.lo: exception.c
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) -fexceptions \
- -o $@
-
-exception_gc.lo: exception.c
- $(LIBTOOL_COMPILE) $(CC) $< -c \
- $(ALL_CFLAGS) $(INCLUDES) $(OBJC_GCFLAGS) -fexceptions \
- -o $@
-
doc: info dvi pdf html
# No install-html or install-pdf support
@@ -269,12 +190,6 @@ libgcobol$(libsuffix).la: $(OBJS)
-version-info $(LIBGCOBOL_VERSION) $(extra_ldflags_libgcobol) \
$(LTLDFLAGS)
-libgcobol_gc$(libsuffix).la: $(OBJS_GC)
- $(LIBTOOL_LINK) $(CC) -o $@ $(OBJS_GC) $(OBJC_BOEHM_GC_LIBS) \
- -Wc,-shared-libgcc -rpath $(toolexeclibdir) \
- -version-info $(LIBGCOBOL_GC_VERSION) $(extra_ldflags_libgcobol) \
- $(LTLDFLAGS)
-
info:
dvi:
pdf:
@@ -289,51 +204,27 @@ config.status: configure
CPPFLAGS='$(CPPFLAGS)' $(SHELL) config.status --recheck
AUTOCONF = autoconf
-ACLOCAL = aclocal
-ACLOCAL_AMFLAGS = -I ../config -I ..
-aclocal_deps = \
- $(srcdir)/../config/multi.m4 \
- $(srcdir)/../config/override.m4 \
- $(srcdir)/../config/proginstall.m4 \
- $(srcdir)/../config/toolexeclibdir.m4 \
- $(srcdir)/../ltoptions.m4 \
- $(srcdir)/../ltsugar.m4 \
- $(srcdir)/../ltversion.m4 \
- $(srcdir)/../lt~obsolete.m4 \
- $(srcdir)/../config/cet.m4 \
- $(srcdir)/acinclude.m4
-
-$(srcdir)/configure: @MAINT@ configure.ac $(srcdir)/aclocal.m4
- rm -f config.cache
- cd $(srcdir) && $(AUTOCONF)
-
-$(srcdir)/aclocal.m4: @MAINT@ $(aclocal_deps)
- cd $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS)
install: install-libs install-headers
install-libs: installdirs
$(SHELL) $(multi_basedir)/mkinstalldirs $(DESTDIR)$(toolexeclibdir)
$(LIBTOOL_INSTALL) $(INSTALL) libgcobol$(libsuffix).la $(DESTDIR)$(toolexeclibdir);
- if [ "$(OBJC_BOEHM_GC)" ]; then \
- $(LIBTOOL_INSTALL) $(INSTALL) libgcobol_gc$(libsuffix).la \
- $(DESTDIR)$(toolexeclibdir);\
- fi
$(MULTIDO) $(FLAGS_TO_PASS) multi-do DO="$@"
@-$(LIBTOOL) --mode=finish $(DESTDIR)$(toolexeclibdir)
# Copy Objective-C headers to installation include directory.
install-headers:
- $(SHELL) $(multi_basedir)/mkinstalldirs $(DESTDIR)$(libsubdir)/$(includedirname)/objc
- for file in $(OBJC_H); do \
+ $(SHELL) $(multi_basedir)/mkinstalldirs $(DESTDIR)$(libsubdir)/$(includedirname)/gcobol
+ for file in $(GCOBOL_H); do \
realfile=$(srcdir)/objc/$${file}; \
- $(INSTALL_DATA) $${realfile} $(DESTDIR)$(libsubdir)/$(includedirname)/objc; \
+ $(INSTALL_DATA) $${realfile} $(DESTDIR)$(libsubdir)/$(includedirname)/gcobol; \
done
check uninstall install-strip dist installcheck installdirs:
mostlyclean:
- -$(LIBTOOL_CLEAN) rm -f libgcobol$(libsuffix).la libgcobol_gc$(libsuffix).la *.lo
+ -$(LIBTOOL_CLEAN) rm -f libgcobol$(libsuffix).la *.lo
-rm -f runtime-info.h tmp-runtime.s *.o *.lo libgcobol* xforward \
fflags *.aux *.cp *.dvi *.pdf *.fn *.info *.ky *.log *.pg \
*.toc *.tp *.vr *.html libobj.exp
@@ -352,6 +243,6 @@ maintainer-clean realclean: distclean
.PHONY: mostlyclean clean distclean maintainer-clean all check uninstall \
install-strip dist installcheck installdirs
-# Don't export variables to the environment, in order to not confuse
+# Don't export variables to the environment, in order not to confuse
# configure.
.NOEXPORT:
diff --git a/libgcobol/NXConstStr.m b/libgcobol/NXConstStr.m
deleted file mode 100644
index f44109984a07..000000000000
--- a/libgcobol/NXConstStr.m
+++ /dev/null
@@ -1,41 +0,0 @@
-/* Implementation of the NXConstantString class for Objective-C.
- Copyright (C) 1995-2022 Free Software Foundation, Inc.
- Contributed by Pieter J. Schoenmakers <tiggr@es.ele.tue.nl>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/NXConstStr.h"
-
-@implementation NXConstantString
-
--(const char *) cString
-{
- return (c_string);
-} /* -cString */
-
--(unsigned int) length
-{
- return (len);
-} /* -length */
-
-@end
diff --git a/libgcobol/Object.m b/libgcobol/Object.m
deleted file mode 100644
index dda6b5ff11ba..000000000000
--- a/libgcobol/Object.m
+++ /dev/null
@@ -1,41 +0,0 @@
-/* The implementation of class Object for Objective-C.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/Object.h"
-#include "objc/runtime.h"
-
-@implementation Object
-
-- (Class)class
-{
- return object_getClass (self);
-}
-
-- (BOOL)isEqual: (id)anObject
-{
- return self == anObject;
-}
-
-@end
diff --git a/libgcobol/Protocol.m b/libgcobol/Protocol.m
deleted file mode 100644
index 87e06ac690a0..000000000000
--- a/libgcobol/Protocol.m
+++ /dev/null
@@ -1,34 +0,0 @@
-/* This file contains the implementation of class Protocol.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc/Protocol.h"
-
-@implementation Protocol
-- (BOOL) isEqual: (id)obj
-{
- return protocol_isEqual (self, obj);
-}
-@end
diff --git a/libgcobol/THREADS b/libgcobol/THREADS
deleted file mode 100644
index 4e068c41dd6a..000000000000
--- a/libgcobol/THREADS
+++ /dev/null
@@ -1,339 +0,0 @@
-This file describes in little detail the modifications to the
-Objective-C runtime needed to make it thread safe.
-
-First off, kudos to Galen Hunt who is the author of this great work.
-
-If you have an comments or just want to know where to
-send me money to express your undying gratitude for threading the
-Objective-C runtime you can reach Galen at:
-
- gchunt@cs.rochester.edu
-
-Any questions, comments, bug reports, etc. should send email either to the
-GCC bug account or to:
-
- Scott Christley <scottc@net-community.com>
-
-* Sarray Threading:
-
-The most critical component of the Objective-C runtime is the sparse array
-structure (sarray). Sarrays store object selectors and implementations.
-Following in the tradition of the Objective-C runtime, my threading
-support assumes that fast message dispatching is far more important
-than *ANY* and *ALL* other operations. The message dispatching thus
-uses *NO* locks on any kind. In fact, if you look in sarray.h, you
-will notice that the message dispatching has not been modified.
-Instead, I have modified the sarray management functions so that all
-updates to the sarray data structure can be made in parallel will
-message dispatching.
-
-To support concurrent message dispatching, no dynamically allocated
-sarray data structures are freed while more than one thread is
-operational. Sarray data structures that are no longer in use are
-kept in a linked list of garbage and are released whenever the program
-is operating with a single thread. The programmer can also flush the
-garbage list by calling sarray_remove_garbage when the programmer can
-ensure that no message dispatching is taking place concurrently. The
-amount of un-reclaimed sarray garbage should normally be extremely
-small in a real program as sarray structures are freed only when using
-the "poseAs" functionality and early in program initialization, which
-normally occurs while the program is single threaded.
-
-******************************************************************************
-* Static Variables:
-
-The following variables are either statically or globally defined. This list
-does not include variables which are internal to implementation dependent
-versions of thread-*.c.
-
-The following threading designations are used:
- SAFE : Implicitly thread safe.
- SINGLE : Must only be used in single thread mode.
- MUTEX : Protected by single global mutex objc_runtime_mutex.
- UNUSED : Not used in the runtime.
-
-Variable Name: Usage: Defined: Also used in:
-=========================== ====== ============ =====================
-__objc_class_hash MUTEX class.c
-__objc_class_links_resolved UNUSED class.c runtime.h
-__objc_class_number MUTEX class.c
-__objc_dangling_categories UNUSED init.c
-__objc_module_list MUTEX init.c
-__objc_selector_array MUTEX selector.c
-__objc_selector_hash MUTEX selector.c
-__objc_selector_max_index MUTEX selector.c sendmsg.c runtime.h
-__objc_selector_names MUTEX selector.c
-__objc_thread_exit_status SAFE thread.c
-__objc_uninstalled_dtable MUTEX sendmsg.c selector.c
-_objc_load_callback SAFE init.c objc-api.h
-_objc_lookup_class SAFE class.c objc-api.h
-_objc_object_alloc SINGLE objects.c objc-api.h
-_objc_object_copy SINGLE objects.c objc-api.h
-_objc_object_dispose SINGLE objects.c objc-api.h
-frwd_sel SAFE2 sendmsg.c
-idxsize MUTEX sarray.c sendmsg.c sarray.h
-initialize_sel SAFE2 sendmsg.c
-narrays MUTEX sarray.c sendmsg.c sarray.h
-nbuckets MUTEX sarray.c sendmsg.c sarray.h
-nindices MUTEX sarray.c sarray.h
-previous_constructors SAFE1 init.c
-proto_class SAFE1 init.c
-unclaimed_categories MUTEX init.c
-unclaimed_proto_list MUTEX init.c
-uninitialized_statics MUTEX init.c
-
-Notes:
-1) Initialized once in unithread mode.
-2) Initialized value will always be same, guaranteed by lock on selector
- hash table.
-
-
-******************************************************************************
-* Frontend/Backend design:
-
-The design of the Objective-C runtime thread and mutex functions utilizes a
-frontend/backend implementation.
-
-The frontend, as characterized by the files thr.h and thr.c, is a set
-of platform independent structures and functions which represent the
-user interface. For example, objc_mutex_lock(). Objective-C programs
-should use these structures and functions for their thread and mutex
-work if they wish to maintain a high degree of portability across
-platforms.
-
-The backend is currently GCC's gthread code (gthr.h and related). For
-example, __gthread_objc_mutex_lock(). The thread system is
-automatically configured when GCC is configured. On most platforms
-this thread backend is able to automatically switch to non-multi-threaded
-mode if the threading library is not linked in.
-
-If you want to compile libobjc standalone, then you would need to modify
-the configure.ac and makefiles for it and you need to import the
-gthread code from GCC.
-
-******************************************************************************
-* Threads:
-
-The thread system attempts to create multiple threads using whatever
-operating system or library thread support is available. It does
-assume that all system functions are thread safe. Notably this means
-that the system implementation of malloc and free must be thread safe.
-If a system has multiple processors, the threads are configured for
-full parallel processing.
-
-* Backend initialization functions
-
-__objc_init_thread_system(void), int
- Initialize the thread subsystem. Called once by __objc_exec_class.
- Return -1 if error otherwise return 0.
-
-__objc_close_thread_system(void), int
- Closes the thread subsystem, not currently guaranteed to be called.
- Return -1 if error otherwise return 0.
-
-*****
-* Frontend thread functions
-* User programs should use these functions.
-
-objc_thread_detach(SEL selector, id object, id argument), objc_thread_t
- Creates and detaches a new thread. The new thread starts by
- sending the given selector with a single argument to the
- given object.
-
-objc_thread_set_priority(int priority), int
- Sets a thread's relative priority within the program. Valid
- options are:
-
- OBJC_THREAD_INTERACTIVE_PRIORITY
- OBJC_THREAD_BACKGROUND_PRIORITY
- OBJC_THREAD_LOW_PRIORITY
-
-objc_thread_get_priority(void), int
- Query a thread's priority.
-
-objc_thread_yield(void), void
- Yields processor to another thread with equal or higher
- priority. It is up to the system scheduler to determine if
- the processor is taken or not.
-
-objc_thread_exit(void), int
- Terminates a thread. If this is the last thread executing
- then the program will terminate.
-
-objc_thread_id(void), int
- Returns the current thread's id.
-
-objc_thread_set_data(void *value), int
- Set a pointer to the thread's local storage. Local storage is
- thread specific.
-
-objc_thread_get_data(void), void *
- Returns the pointer to the thread's local storage.
-
-*****
-* Backend thread functions
-* User programs should *NOT* directly call these functions.
-
-__gthr_objc_thread_detach(void (*func)(void *arg), void *arg), objc_thread_t
- Spawns a new thread executing func, called by objc_thread_detach.
- Return NULL if error otherwise return thread id.
-
-__gthr_objc_thread_set_priority(int priority), int
- Set the thread's priority, called by objc_thread_set_priority.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_thread_get_priority(void), int
- Query a thread's priority, called by objc_thread_get_priority.
- Return -1 if error otherwise return the priority.
-
-__gthr_objc_thread_yield(void), void
- Yields the processor, called by objc_thread_yield.
-
-__gthr_objc_thread_exit(void), int
- Terminates the thread, called by objc_thread_exit.
- Return -1 if error otherwise function does not return.
-
-__gthr_objc_thread_id(void), objc_thread_t
- Returns the current thread's id, called by objc_thread_id.
- Return -1 if error otherwise return thread id.
-
-__gthr_objc_thread_set_data(void *value), int
- Set pointer for thread local storage, called by objc_thread_set_data.
- Returns -1 if error otherwise return 0.
-
-__gthr_objc_thread_get_data(void), void *
- Returns the pointer to the thread's local storage.
- Returns NULL if error, called by objc_thread_get_data.
-
-
-******************************************************************************
-* Mutexes:
-
-Mutexes can be locked recursively. Each locked mutex remembers
-its owner (by thread id) and how many times it has been locked. The
-last unlock on a mutex removes the system lock and allows other
-threads to access the mutex.
-
-*****
-* Frontend mutex functions
-* User programs should use these functions.
-
-objc_mutex_allocate(void), objc_mutex_t
- Allocates a new mutex. Mutex is initially unlocked.
- Return NULL if error otherwise return mutex pointer.
-
-objc_mutex_deallocate(objc_mutex_t mutex), int
- Free a mutex. Before freeing the mutex, makes sure that no
- one else is using it.
- Return -1 if error otherwise return 0.
-
-objc_mutex_lock(objc_mutex_t mutex), int
- Locks a mutex. As mentioned earlier, the same thread may call
- this routine repeatedly.
- Return -1 if error otherwise return 0.
-
-objc_mutex_trylock(objc_mutex_t mutex), int
- Attempts to lock a mutex. If lock on mutex can be acquired
- then function operates exactly as objc_mutex_lock.
- Return -1 if failed to acquire lock otherwise return 0.
-
-objc_mutex_unlock(objc_mutex_t mutex), int
- Unlocks the mutex by one level. Other threads may not acquire
- the mutex until this thread has released all locks on it.
- Return -1 if error otherwise return 0.
-
-*****
-* Backend mutex functions
-* User programs should *NOT* directly call these functions.
-
-__gthr_objc_mutex_allocate(objc_mutex_t mutex), int
- Allocates a new mutex, called by objc_mutex_allocate.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_mutex_deallocate(objc_mutex_t mutex), int
- Free a mutex, called by objc_mutex_deallocate.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_mutex_lock(objc_mutex_t mutex), int
- Locks a mutex, called by objc_mutex_lock.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_mutex_trylock(objc_mutex_t mutex), int
- Attempts to lock a mutex, called by objc_mutex_trylock.
- Return -1 if failed to acquire lock or error otherwise return 0.
-
-__gthr_objc_mutex_unlock(objc_mutex_t mutex), int
- Unlocks the mutex, called by objc_mutex_unlock.
- Return -1 if error otherwise return 0.
-
-******************************************************************************
-* Condition Mutexes:
-
-Mutexes can be locked recursively. Each locked mutex remembers
-its owner (by thread id) and how many times it has been locked. The
-last unlock on a mutex removes the system lock and allows other
-threads to access the mutex.
-
-*
-* Frontend condition mutex functions
-* User programs should use these functions.
-*
-
-objc_condition_allocate(void), objc_condition_t
- Allocate a condition mutex.
- Return NULL if error otherwise return condition pointer.
-
-objc_condition_deallocate(objc_condition_t condition), int
- Deallocate a condition. Note that this includes an implicit
- condition_broadcast to insure that waiting threads have the
- opportunity to wake. It is legal to dealloc a condition only
- if no other thread is/will be using it. Does NOT check for
- other threads waiting but just wakes them up.
- Return -1 if error otherwise return 0.
-
-objc_condition_wait(objc_condition_t condition, objc_mutex_t mutex), int
- Wait on the condition unlocking the mutex until objc_condition_signal()
- or objc_condition_broadcast() are called for the same condition. The
- given mutex *must* have the depth 1 so that it can be unlocked
- here, for someone else can lock it and signal/broadcast the condition.
- The mutex is used to lock access to the shared data that make up the
- "condition" predicate.
- Return -1 if error otherwise return 0.
-
-objc_condition_broadcast(objc_condition_t condition), int
- Wake up all threads waiting on this condition. It is recommended that
- the called would lock the same mutex as the threads in
- objc_condition_wait before changing the "condition predicate"
- and make this call and unlock it right away after this call.
- Return -1 if error otherwise return 0.
-
-objc_condition_signal(objc_condition_t condition), int
- Wake up one thread waiting on this condition.
- Return -1 if error otherwise return 0.
-
-*
-* Backend condition mutex functions
-* User programs should *NOT* directly call these functions.
-*
-
-__gthr_objc_condition_allocate(objc_condition_t condition), int
- Allocate a condition mutex, called by objc_condition_allocate.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_condition_deallocate(objc_condition_t condition), int
- Deallocate a condition, called by objc_condition_deallocate.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_condition_wait(objc_condition_t condition, objc_mutex_t mutex), int
- Wait on the condition, called by objc_condition_wait.
- Return -1 if error otherwise return 0 when condition is met.
-
-__gthr_objc_condition_broadcast(objc_condition_t condition), int
- Wake up all threads waiting on this condition.
- Called by objc_condition_broadcast.
- Return -1 if error otherwise return 0.
-
-__gthr_objc_condition_signal(objc_condition_t condition), int
- Wake up one thread waiting on this condition.
- Called by objc_condition_signal.
- Return -1 if error otherwise return 0.
diff --git a/libgcobol/accessors.m b/libgcobol/accessors.m
deleted file mode 100644
index 16e4d4833675..000000000000
--- a/libgcobol/accessors.m
+++ /dev/null
@@ -1,289 +0,0 @@
-/* GNU Objective C Runtime accessors functions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/objc.h"
-#include "objc/thr.h"
-#include <string.h> /* For memcpy */
-
-/* This file contains functions that the compiler uses when
- synthesizing accessors (getters/setters) for properties. The
- functions are part of the ABI, but are meant to be used by the
- compiler and not by users; for this reason, they are not declared
- in public header files. The compiler automatically generates
- declarations for these functions. */
-
-/* Properties can be "atomic", which requires protecting them from
- concurrency issues using a lock. Unfortunately, we can't have a
- lock for each property, so we'll go with a small pool of locks.
- Any time a property is accessed in an "atomic" way, we pick a
- random lock from the pool (random, but always the same one for the
- same property of the same object) and use it to protect access to
- the property.
-
- The size of the pool is currently 16. A bigger pool can help
- reduce contention, ie, reduce the chances that two threads,
- operating on unrelated properties, will have to wait for each other
- because the properties use the same lock. 16 seems big enough at
- the moment. */
-#define ACCESSORS_NUMBER_OF_LOCKS 16
-
-#define ACCESSORS_HASH(POINTER) ((((size_t)POINTER >> 8) ^ (size_t)POINTER) & (ACCESSORS_NUMBER_OF_LOCKS - 1))
-
-static objc_mutex_t accessors_locks[ACCESSORS_NUMBER_OF_LOCKS];
-
-/* This is called at startup to setup the locks. */
-void
-__objc_accessors_init (void)
-{
- int i;
-
- for (i = 0; i < ACCESSORS_NUMBER_OF_LOCKS; i++)
- accessors_locks[i] = objc_mutex_allocate ();
-}
-
-/* The property accessors automatically call various methods from the
- Foundation library (eg, GNUstep-base). These methods are not
- implemented here, but we need to declare them so we can compile the
- runtime. The Foundation library will need to provide
- implementations of these methods (most likely in the root class,
- eg, NSObject) as the accessors only work with objects of classes
- that implement these methods. */
-@interface _libobjcNSObject
-- (id) copyWithZone: (void *)zone;
-- (id) mutableCopyWithZone: (void *)zone;
-@end
-#define COPY(X) [((_libobjcNSObject *)(X)) copyWithZone: NULL]
-#define MUTABLE_COPY(X) [((_libobjcNSObject *)(X)) mutableCopyWithZone: NULL]
-
-
-#if OBJC_WITH_GC
-
-# define AUTORELEASE(X) (X)
-# define RELEASE(X)
-# define RETAIN(X) (X)
-
-#else
-
-@interface _libobjcNSObject (RetainReleaseMethods)
-- (id) autorelease;
-- (oneway void) release;
-- (id) retain;
-@end
-# define AUTORELEASE(X) [((_libobjcNSObject *)(X)) autorelease]
-# define RELEASE(X) [((_libobjcNSObject *)(X)) release]
-# define RETAIN(X) [((_libobjcNSObject *)(X)) retain]
-
-#endif
-
-/* The compiler uses this function when implementing some synthesized
- getters for properties of type 'id'. */
-id
-objc_getProperty (id self, SEL __attribute__((unused)) _cmd, ptrdiff_t offset, BOOL is_atomic)
-{
- if (self != nil)
- {
- id *pointer_to_ivar = (id *)((char *)self + offset);
-
-
- if (is_atomic == NO)
- {
- /* Note that in this case, we do not RETAIN/AUTORELEASE the
- returned value. The programmer should do it if it is
- needed. Since access is non-atomic, other threads can be
- ignored and the caller has full control of what happens
- to the object and whether it needs to be RETAINed or not,
- so it makes sense to leave the decision to him/her. This
- is also what the Apple/NeXT runtime does. */
- return *pointer_to_ivar;
- }
- else
- {
- objc_mutex_t lock = accessors_locks[ACCESSORS_HASH (pointer_to_ivar)];
- id result;
-
- objc_mutex_lock (lock);
- result = RETAIN (*(pointer_to_ivar));
- objc_mutex_unlock (lock);
-
- return AUTORELEASE (result);
- }
- }
-
- return nil;
-}
-
-/* The compiler uses this function when implementing some synthesized
- setters for properties of type 'id'.
-
- PS: Note how 'should_copy' is declared 'BOOL' but then actually
- takes values from 0 to 2. This hack was introduced by Apple; we
- do the same for compatibility reasons. */
-void
-objc_setProperty (id self, SEL __attribute__((unused)) _cmd, ptrdiff_t offset, id new_value, BOOL is_atomic, BOOL should_copy)
-{
- if (self != nil)
- {
- id *pointer_to_ivar = (id *)((char *)self + offset);
- id retained_value;
-#if !OBJC_WITH_GC
- id old_value;
-#endif
-
- switch (should_copy)
- {
- case 0: /* retain */
- {
- if (*pointer_to_ivar == new_value)
- return;
- retained_value = RETAIN (new_value);
- break;
- }
- case 2: /* mutable copy */
- {
- retained_value = MUTABLE_COPY (new_value);
- break;
- }
- case 1: /* copy */
- default:
- {
- retained_value = COPY (new_value);
- break;
- }
- }
-
- if (is_atomic == NO)
- {
-#if !OBJC_WITH_GC
- old_value = *pointer_to_ivar;
-#endif
- *pointer_to_ivar = retained_value;
- }
- else
- {
- objc_mutex_t lock = accessors_locks[ACCESSORS_HASH (pointer_to_ivar)];
-
- objc_mutex_lock (lock);
-#if !OBJC_WITH_GC
- old_value = *pointer_to_ivar;
-#endif
- *pointer_to_ivar = retained_value;
- objc_mutex_unlock (lock);
- }
-#if !OBJC_WITH_GC
- RELEASE (old_value);
-#endif
- }
-}
-
-/* The compiler uses this function when implementing some synthesized
- getters for properties of arbitrary C types. The data is just
- copied. Compatibility Note: this function does not exist in the
- Apple/NeXT runtime. */
-void
-objc_getPropertyStruct (void *destination, const void *source, ptrdiff_t size, BOOL is_atomic, BOOL __attribute__((unused)) has_strong)
-{
- if (is_atomic == NO)
- memcpy (destination, source, size);
- else
- {
- objc_mutex_t lock = accessors_locks[ACCESSORS_HASH (source)];
-
- objc_mutex_lock (lock);
- memcpy (destination, source, size);
- objc_mutex_unlock (lock);
- }
-}
-
-/* The compiler uses this function when implementing some synthesized
- setters for properties of arbitrary C types. The data is just
- copied. Compatibility Note: this function does not exist in the
- Apple/NeXT runtime. */
-void
-objc_setPropertyStruct (void *destination, const void *source, ptrdiff_t size, BOOL is_atomic, BOOL __attribute__((unused)) has_strong)
-{
- if (is_atomic == NO)
- memcpy (destination, source, size);
- else
- {
- objc_mutex_t lock = accessors_locks[ACCESSORS_HASH (destination)];
-
- objc_mutex_lock (lock);
- memcpy (destination, source, size);
- objc_mutex_unlock (lock);
- }
-}
-
-/* This is the function that the Apple/NeXT runtime has instead of
- objc_getPropertyStruct and objc_setPropertyStruct. We include it
- for API compatibility (just for people who may have used
- objc_copyStruct on the NeXT runtime thinking it was a public API);
- the compiler never generates calls to it with the GNU runtime.
- This function is clumsy because it requires two locks instead of
- one. */
-void
-objc_copyStruct (void *destination, const void *source, ptrdiff_t size, BOOL is_atomic, BOOL __attribute__((unused)) has_strong)
-{
- if (is_atomic == NO)
- memcpy (destination, source, size);
- else
- {
- /* We don't know which one is the property, so we have to lock
- both. One of them is most likely a temporary buffer in the
- local stack and we really wouldn't want to lock it (our
- objc_getPropertyStruct and objc_setPropertyStruct functions
- don't lock it). Note that if we're locking more than one
- accessor lock at once, we need to always lock them in the
- same order to avoid deadlocks. */
- objc_mutex_t first_lock;
- objc_mutex_t second_lock;
-
- if (ACCESSORS_HASH (source) == ACCESSORS_HASH (destination))
- {
- /* A lucky collision. */
- first_lock = accessors_locks[ACCESSORS_HASH (source)];
- objc_mutex_lock (first_lock);
- memcpy (destination, source, size);
- objc_mutex_unlock (first_lock);
- return;
- }
-
- if (ACCESSORS_HASH (source) > ACCESSORS_HASH (destination))
- {
- first_lock = accessors_locks[ACCESSORS_HASH (source)];
- second_lock = accessors_locks[ACCESSORS_HASH (destination)];
- }
- else
- {
- first_lock = accessors_locks[ACCESSORS_HASH (destination)];
- second_lock = accessors_locks[ACCESSORS_HASH (source)];
- }
-
- objc_mutex_lock (first_lock);
- objc_mutex_lock (second_lock);
- memcpy (destination, source, size);
- objc_mutex_unlock (second_lock);
- objc_mutex_unlock (first_lock);
- }
-}
diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc
new file mode 100644
index 000000000000..948766845e5a
--- /dev/null
+++ b/libgcobol/charmaps.cc
@@ -0,0 +1,777 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.s
+ * distribution.s
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (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 <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 <algorithm>
+
+#include <langinfo.h>
+#include <unordered_map>
+#include <locale.h>
+
+#include "libgcobol.h"
+#include "charmaps.h"
+
+// First: single-byte-coded (SBC) character sets:
+
+// 7-bit ASCII is a subset of the various ISO/IEC 8859 code pages.
+// 8859 is a subset of code page 1252.
+// CP1252 is informally, and improperly, known as the "ANSI" code set. In
+// modern usage, when somebody says "8859-1", they almost invariably are
+// referring to a CP1252 code set.
+
+// EBCDIC is also an SBC character set. IBM's original "international EBCDIC"
+// code set was Code Page 37, which did not have a Euro sign. Code Page 1140
+// is the same as CP37, but with the Euro sign replacing the "universal
+// currency symbol" at position 0x9F. The table below maps the 256 values of
+// CodePage 1140 to the 256 values of CodePage 1252 in a way that allows for
+// "round trip" conversion without any loss.
+
+// See https://en.wikipedia.org/w/index.php?title=Code_page_37&oldid=1082467670,
+
+// The modern world increasingly uses UTF-8, which is in conflict with ordinary
+// COBOL's inherently single-byte nature. In UTF-8, the encoding for a Euro
+// sign is three bytes (U+20AC encodes to E2 A2 AC). In single-byte CP1252, the
+// Euro is encoded as 0x80.
+
+// So, we are going to assume that internally, the generated COBOL executable
+// operates in code page 1252 or [hopefully some day] code page 1140.
+
+// We will convert output, as in DISPLAY <something> from the internal character
+// set to the running machine's locale (for now, that locale will be assumed to
+// be 1252/8859 if it isn't UTF-8).
+
+// And we will take some pains to figure out if the source code file was done
+// as UTF-8; if not, we will assume 1252/8859-1
+
+// __gg__ebcdic_codeset_in_use is the ultimate determinator of whether the
+// internal codeset is ASCII/CP1252 or EBCDIC/CP1140.
+bool __gg__ebcdic_codeset_in_use = false ;
+
+static text_codeset_t source_codeset = cs_default_e;
+static text_codeset_t console_codeset = cs_default_e;
+
+#define UNICODE_REPLACEMENT 0xFFFD // This a white question mark in a black diamond
+#define ASCII_REPLACEMENT 0x87 // In CP1252, 0x87 is a double-dagger
+
+// This table is the default one-to-one mapping that's used, for example, when
+// starting with ASCII and doing ASCII comparisons:
+
+const unsigned char
+__gg__one_to_one_values[256] =
+ {
+ 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
+ 0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
+ 0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
+ 0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
+ 0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
+ 0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
+ 0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
+ 0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
+ 0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
+ 0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
+ 0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
+ 0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
+ 0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
+ 0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
+ 0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
+ 0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF
+ };
+
+// This table can be used for converting EBCDIC values to CP1252
+const unsigned char
+__gg__cp1140_to_cp1252_values[256] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0xA4, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xE2, 0xE4, 0xE0, 0xE1, 0xE3, 0xE5, 0xE7, 0xF1, 0xA2, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xE9, 0xEA, 0xEB, 0xE8, 0xED, 0xEE, 0xEF, 0xEC, 0xDF, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0xAC,
+ 0x2D, 0x2F, 0xC2, 0xC4, 0xC0, 0xC1, 0xC3, 0xC5, 0xC7, 0xD1, 0xA6, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xF8, 0xC9, 0xCA, 0xCB, 0xC8, 0xCD, 0xCE, 0xCF, 0xCC, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xD8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xAB, 0xBB, 0xF0, 0xFD, 0xFE, 0xB1,
+ 0xB0, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xAA, 0xBA, 0xE6, 0xB8, 0xC6, 0x80,
+ 0xB5, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xA1, 0xBF, 0xD0, 0xDD, 0xDE, 0xAE,
+ 0x5E, 0xA3, 0xA5, 0xB7, 0xA9, 0xA7, 0xB6, 0xBC, 0xBD, 0xBE, 0x5B, 0x5D, 0xAF, 0xA8, 0xB4, 0xD7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xAD, 0xF4, 0xF6, 0xF2, 0xF3, 0xF5,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xB9, 0xFB, 0xFC, 0xF9, 0xFA, 0xFF,
+ 0x5C, 0xF7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xB2, 0xD4, 0xD6, 0xD2, 0xD3, 0xD5,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0xDB, 0xDC, 0xD9, 0xDA, 0x9F,
+ };
+
+// This table is the mirror image of cp1140_to_cp1252_values, so it is used to
+// convert CP1252 to CP1140
+const unsigned char
+__gg__cp1252_to_cp1140_values[256] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
+ 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
+ 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
+ 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xBA, 0xE0, 0xBB, 0xB0, 0x6D,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, 0xA8, 0xA9, 0xC0, 0x4F, 0xD0, 0xA1, 0x07,
+ 0x9F, 0x21, 0x22, 0x23, 0x24, 0x15, 0x06, 0x17, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x09, 0x0A, 0x1B,
+ 0x30, 0x31, 0x1A, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3A, 0x3B, 0x04, 0x14, 0x3E, 0xFF,
+ 0x41, 0xAA, 0x4A, 0xB1, 0x20, 0xB2, 0x6A, 0xB5, 0xBD, 0xB4, 0x9A, 0x8A, 0x5F, 0xCA, 0xAF, 0xBC,
+ 0x90, 0x8F, 0xEA, 0xFA, 0xBE, 0xA0, 0xB6, 0xB3, 0x9D, 0xDA, 0x9B, 0x8B, 0xB7, 0xB8, 0xB9, 0xAB,
+ 0x64, 0x65, 0x62, 0x66, 0x63, 0x67, 0x9E, 0x68, 0x74, 0x71, 0x72, 0x73, 0x78, 0x75, 0x76, 0x77,
+ 0xAC, 0x69, 0xED, 0xEE, 0xEB, 0xEF, 0xEC, 0xBF, 0x80, 0xFD, 0xFE, 0xFB, 0xFC, 0xAD, 0xAE, 0x59,
+ 0x44, 0x45, 0x42, 0x46, 0x43, 0x47, 0x9C, 0x48, 0x54, 0x51, 0x52, 0x53, 0x58, 0x55, 0x56, 0x57,
+ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF,
+ };
+
+// This is the EBCDIC collating sequence when the internal character set is CP1252. It's actually
+// a copy of __gg__cp1252_to_cp1140_values, but modified so that 0xFF maps to 0xFF.
+// Doing this meant swapping the CP1252 upper-Y-umlaut with lower-Y-umlaut.
+const unsigned char
+__gg__cp1252_to_ebcdic_collation[256] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2d, 0x2e, 0x2f, 0x16, 0x05, 0x25, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+ 0x10, 0x11, 0x12, 0x13, 0x3c, 0x3d, 0x32, 0x26, 0x18, 0x19, 0x3f, 0x27, 0x1c, 0x1d, 0x1e, 0x1f,
+ 0x40, 0x5a, 0x7f, 0x7b, 0x5b, 0x6c, 0x50, 0x7d, 0x4d, 0x5d, 0x5c, 0x4e, 0x6b, 0x60, 0x4b, 0x61,
+ 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0x7a, 0x5e, 0x4c, 0x7e, 0x6e, 0x6f,
+ 0x7c, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6,
+ 0xd7, 0xd8, 0xd9, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xba, 0xe0, 0xbb, 0xb0, 0x6d,
+ 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xc0, 0x4f, 0xd0, 0xa1, 0x07,
+ 0x9f, 0x21, 0x22, 0x23, 0x24, 0x15, 0x06, 0x17, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x09, 0x0a, 0x1b,
+ 0x30, 0x31, 0x1a, 0x33, 0x34, 0x35, 0x36, 0x08, 0x38, 0x39, 0x3a, 0x3b, 0x04, 0x14, 0x3e, 0xdf,
+ 0x41, 0xaa, 0x4a, 0xb1, 0x20, 0xb2, 0x6a, 0xb5, 0xbd, 0xb4, 0x9a, 0x8a, 0x5f, 0xca, 0xaf, 0xbc,
+ 0x90, 0x8f, 0xea, 0xfa, 0xbe, 0xa0, 0xb6, 0xb3, 0x9d, 0xda, 0x9b, 0x8b, 0xb7, 0xb8, 0xb9, 0xab,
+ 0x64, 0x65, 0x62, 0x66, 0x63, 0x67, 0x9e, 0x68, 0x74, 0x71, 0x72, 0x73, 0x78, 0x75, 0x76, 0x77,
+ 0xac, 0x69, 0xed, 0xee, 0xeb, 0xef, 0xec, 0xbf, 0x80, 0xfd, 0xfe, 0xfb, 0xfc, 0xad, 0xae, 0x59,
+ 0x44, 0x45, 0x42, 0x46, 0x43, 0x47, 0x9c, 0x48, 0x54, 0x51, 0x52, 0x53, 0x58, 0x55, 0x56, 0x57,
+ 0x8c, 0x49, 0xcd, 0xce, 0xcb, 0xcf, 0xcc, 0xe1, 0x70, 0xdd, 0xde, 0xdb, 0xdc, 0x8d, 0x8e, 0xff,
+ };
+
+// When using the EBCDIC internal character set, but if told to use the ASCII collating sequence,
+// this table can be used. It's based on the __gg__cp1140_to_cp1252_values, but with the two
+// characters at locations DF and FF swapped so that the HIGH-VALUE 0xFF maps to 0xFF.
+const unsigned char
+__gg__ebcdic_to_cp1252_collation[256] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
+ 0xA4, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
+ 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9A, 0x9B, 0x14, 0x15, 0x9E, 0x1A,
+ 0x20, 0xA0, 0xE2, 0xE4, 0xE0, 0xE1, 0xE3, 0xE5, 0xE7, 0xF1, 0xA2, 0x2E, 0x3C, 0x28, 0x2B, 0x7C,
+ 0x26, 0xE9, 0xEA, 0xEB, 0xE8, 0xED, 0xEE, 0xEF, 0xEC, 0xDF, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0xAC,
+ 0x2D, 0x2F, 0xC2, 0xC4, 0xC0, 0xC1, 0xC3, 0xC5, 0xC7, 0xD1, 0xA6, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
+ 0xF8, 0xC9, 0xCA, 0xCB, 0xC8, 0xCD, 0xCE, 0xCF, 0xCC, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
+ 0xD8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xAB, 0xBB, 0xF0, 0xFD, 0xFE, 0xB1,
+ 0xB0, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0xAA, 0xBA, 0xE6, 0xB8, 0xC6, 0x80,
+ 0xB5, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0xA1, 0xBF, 0xD0, 0xDD, 0xDE, 0xAE,
+ 0x5E, 0xA3, 0xA5, 0xB7, 0xA9, 0xA7, 0xB6, 0xBC, 0xBD, 0xBE, 0x5B, 0x5D, 0xAF, 0xA8, 0xB4, 0xD7,
+ 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xAD, 0xF4, 0xF6, 0xF2, 0xF3, 0xF5,
+ 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0xB9, 0xFB, 0xFC, 0xF9, 0xFA, 0xDF,
+ 0x5C, 0xF7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0xB2, 0xD4, 0xD6, 0xD2, 0xD3, 0xD5,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0xDB, 0xDC, 0xD9, 0xDA, 0xFF,
+ };
+
+// This table is used for converting code page 1252 to the subset of UTF-8 that
+// that contains CP1252
+
+static const unsigned short
+cp1252_to_utf8_values[256] =
+ {
+ 0x0000, 0x0001, 0x0002, 0x0003, 0x0004, 0x0005, 0x0006, 0x0007, 0x0008, 0x0009, 0x000a, 0x000b, 0x000c, 0x000d, 0x000e, 0x000f, // 00
+ 0x0010, 0x0011, 0x0012, 0x0013, 0x0014, 0x0015, 0x0016, 0x0017, 0x0018, 0x0019, 0x001a, 0x001b, 0x001c, 0x001d, 0x001e, 0x001f, // 10
+ 0x0020, 0x0021, 0x0022, 0x0023, 0x0024, 0x0025, 0x0026, 0x0027, 0x0028, 0x0029, 0x002a, 0x002b, 0x002c, 0x002d, 0x002e, 0x002f, // 20
+ 0x0030, 0x0031, 0x0032, 0x0033, 0x0034, 0x0035, 0x0036, 0x0037, 0x0038, 0x0039, 0x003a, 0x003b, 0x003c, 0x003d, 0x003e, 0x003f, // 30
+ 0x0040, 0x0041, 0x0042, 0x0043, 0x0044, 0x0045, 0x0046, 0x0047, 0x0048, 0x0049, 0x004a, 0x004b, 0x004c, 0x004d, 0x004e, 0x004f, // 40
+ 0x0050, 0x0051, 0x0052, 0x0053, 0x0054, 0x0055, 0x0056, 0x0057, 0x0058, 0x0059, 0x005a, 0x005b, 0x005c, 0x005d, 0x005e, 0x005f, // 50
+ 0x0060, 0x0061, 0x0062, 0x0063, 0x0064, 0x0065, 0x0066, 0x0067, 0x0068, 0x0069, 0x006a, 0x006b, 0x006c, 0x006d, 0x006e, 0x006f, // 60
+ 0x0070, 0x0071, 0x0072, 0x0073, 0x0074, 0x0075, 0x0076, 0x0077, 0x0078, 0x0079, 0x007a, 0x007b, 0x007c, 0x007d, 0x007e, 0x007f, // 70
+ 0x20ac, 0x0081, 0x201a, 0x0192, 0x201e, 0x2026, 0x2020, 0x2021, 0x02c6, 0x2030, 0x0160, 0x2039, 0x0152, 0x008d, 0x017d, 0x008f, // 80
+ 0x0090, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014, 0x02dc, 0x2122, 0x0161, 0x203a, 0x0153, 0x009d, 0x017e, 0x0178, // 90
+ 0x00a0, 0x00a1, 0x00a2, 0x00a3, 0x00a4, 0x00a5, 0x00a6, 0x00a7, 0x00a8, 0x00a9, 0x00aa, 0x00ab, 0x00ac, 0x00ad, 0x00ae, 0x00af, // A0
+ 0x00b0, 0x00b1, 0x00b2, 0x00b3, 0x00b4, 0x00b5, 0x00b6, 0x00b7, 0x00b8, 0x00b9, 0x00ba, 0x00bb, 0x00bc, 0x00bd, 0x00be, 0x00bf, // B0
+ 0x00c0, 0x00c1, 0x00c2, 0x00c3, 0x00c4, 0x00c5, 0x00c6, 0x00c7, 0x00c8, 0x00c9, 0x00ca, 0x00cb, 0x00cc, 0x00cd, 0x00ce, 0x00cf, // C0
+ 0x00d0, 0x00d1, 0x00d2, 0x00d3, 0x00d4, 0x00d5, 0x00d6, 0x00d7, 0x00d8, 0x00d9, 0x00da, 0x00db, 0x00dc, 0x00dd, 0x00de, 0x00df, // D0
+ 0x00e0, 0x00e1, 0x00e2, 0x00e3, 0x00e4, 0x00e5, 0x00e6, 0x00e7, 0x00e8, 0x00e9, 0x00ea, 0x00eb, 0x00ec, 0x00ed, 0x00ee, 0x00ef, // E0
+ 0x00f0, 0x00f1, 0x00f2, 0x00f3, 0x00f4, 0x00f5, 0x00f6, 0x00f7, 0x00f8, 0x00f9, 0x00fa, 0x00fb, 0x00fc, 0x00fd, 0x00fe, 0x00ff, // F0
+ };
+
+// This map table doe the reverse UTF-8 conversion back to cp1252
+static const std::unordered_map<unsigned short, unsigned char>utf8_to_cp1252_values =
+ {
+ {0x0000, 0x00}, {0x0001, 0x01}, {0x0002, 0x02}, {0x0003, 0x03}, {0x0004, 0x04}, {0x0005, 0x05}, {0x0006, 0x06}, {0x0007, 0x07},
+ {0x0008, 0x08}, {0x0009, 0x09}, {0x000a, 0x0a}, {0x000b, 0x0b}, {0x000c, 0x0c}, {0x000d, 0x0d}, {0x000e, 0x0e}, {0x000f, 0x0f},
+ {0x0010, 0x10}, {0x0011, 0x11}, {0x0012, 0x12}, {0x0013, 0x13}, {0x0014, 0x14}, {0x0015, 0x15}, {0x0016, 0x16}, {0x0017, 0x17},
+ {0x0018, 0x18}, {0x0019, 0x19}, {0x001a, 0x1a}, {0x001b, 0x1b}, {0x001c, 0x1c}, {0x001d, 0x1d}, {0x001e, 0x1e}, {0x001f, 0x1f},
+ {0x0020, 0x20}, {0x0021, 0x21}, {0x0022, 0x22}, {0x0023, 0x23}, {0x0024, 0x24}, {0x0025, 0x25}, {0x0026, 0x26}, {0x0027, 0x27},
+ {0x0028, 0x28}, {0x0029, 0x29}, {0x002a, 0x2a}, {0x002b, 0x2b}, {0x002c, 0x2c}, {0x002d, 0x2d}, {0x002e, 0x2e}, {0x002f, 0x2f},
+ {0x0030, 0x30}, {0x0031, 0x31}, {0x0032, 0x32}, {0x0033, 0x33}, {0x0034, 0x34}, {0x0035, 0x35}, {0x0036, 0x36}, {0x0037, 0x37},
+ {0x0038, 0x38}, {0x0039, 0x39}, {0x003a, 0x3a}, {0x003b, 0x3b}, {0x003c, 0x3c}, {0x003d, 0x3d}, {0x003e, 0x3e}, {0x003f, 0x3f},
+ {0x0040, 0x40}, {0x0041, 0x41}, {0x0042, 0x42}, {0x0043, 0x43}, {0x0044, 0x44}, {0x0045, 0x45}, {0x0046, 0x46}, {0x0047, 0x47},
+ {0x0048, 0x48}, {0x0049, 0x49}, {0x004a, 0x4a}, {0x004b, 0x4b}, {0x004c, 0x4c}, {0x004d, 0x4d}, {0x004e, 0x4e}, {0x004f, 0x4f},
+ {0x0050, 0x50}, {0x0051, 0x51}, {0x0052, 0x52}, {0x0053, 0x53}, {0x0054, 0x54}, {0x0055, 0x55}, {0x0056, 0x56}, {0x0057, 0x57},
+ {0x0058, 0x58}, {0x0059, 0x59}, {0x005a, 0x5a}, {0x005b, 0x5b}, {0x005c, 0x5c}, {0x005d, 0x5d}, {0x005e, 0x5e}, {0x005f, 0x5f},
+ {0x0060, 0x60}, {0x0061, 0x61}, {0x0062, 0x62}, {0x0063, 0x63}, {0x0064, 0x64}, {0x0065, 0x65}, {0x0066, 0x66}, {0x0067, 0x67},
+ {0x0068, 0x68}, {0x0069, 0x69}, {0x006a, 0x6a}, {0x006b, 0x6b}, {0x006c, 0x6c}, {0x006d, 0x6d}, {0x006e, 0x6e}, {0x006f, 0x6f},
+ {0x0070, 0x70}, {0x0071, 0x71}, {0x0072, 0x72}, {0x0073, 0x73}, {0x0074, 0x74}, {0x0075, 0x75}, {0x0076, 0x76}, {0x0077, 0x77},
+ {0x0078, 0x78}, {0x0079, 0x79}, {0x007a, 0x7a}, {0x007b, 0x7b}, {0x007c, 0x7c}, {0x007d, 0x7d}, {0x007e, 0x7e}, {0x007f, 0x7f},
+ {0x20ac, 0x80}, {0x0081, 0x81}, {0x201a, 0x82}, {0x0192, 0x83}, {0x201e, 0x84}, {0x2026, 0x85}, {0x2020, 0x86}, {0x2021, 0x87},
+ {0x02c6, 0x88}, {0x2030, 0x89}, {0x0160, 0x8a}, {0x2039, 0x8b}, {0x0152, 0x8c}, {0x008d, 0x8d}, {0x017d, 0x8e}, {0x008f, 0x8f},
+ {0x0090, 0x90}, {0x2018, 0x91}, {0x2019, 0x92}, {0x201c, 0x93}, {0x201d, 0x94}, {0x2022, 0x95}, {0x2013, 0x96}, {0x2014, 0x97},
+ {0x02dc, 0x98}, {0x2122, 0x99}, {0x0161, 0x9a}, {0x203a, 0x9b}, {0x0153, 0x9c}, {0x009d, 0x9d}, {0x017e, 0x9e}, {0x0178, 0x9f},
+ {0x00a0, 0xa0}, {0x00a1, 0xa1}, {0x00a2, 0xa2}, {0x00a3, 0xa3}, {0x00a4, 0xa4}, {0x00a5, 0xa5}, {0x00a6, 0xa6}, {0x00a7, 0xa7},
+ {0x00a8, 0xa8}, {0x00a9, 0xa9}, {0x00aa, 0xaa}, {0x00ab, 0xab}, {0x00ac, 0xac}, {0x00ad, 0xad}, {0x00ae, 0xae}, {0x00af, 0xaf},
+ {0x00b0, 0xb0}, {0x00b1, 0xb1}, {0x00b2, 0xb2}, {0x00b3, 0xb3}, {0x00b4, 0xb4}, {0x00b5, 0xb5}, {0x00b6, 0xb6}, {0x00b7, 0xb7},
+ {0x00b8, 0xb8}, {0x00b9, 0xb9}, {0x00ba, 0xba}, {0x00bb, 0xbb}, {0x00bc, 0xbc}, {0x00bd, 0xbd}, {0x00be, 0xbe}, {0x00bf, 0xbf},
+ {0x00c0, 0xc0}, {0x00c1, 0xc1}, {0x00c2, 0xc2}, {0x00c3, 0xc3}, {0x00c4, 0xc4}, {0x00c5, 0xc5}, {0x00c6, 0xc6}, {0x00c7, 0xc7},
+ {0x00c8, 0xc8}, {0x00c9, 0xc9}, {0x00ca, 0xca}, {0x00cb, 0xcb}, {0x00cc, 0xcc}, {0x00cd, 0xcd}, {0x00ce, 0xce}, {0x00cf, 0xcf},
+ {0x00d0, 0xd0}, {0x00d1, 0xd1}, {0x00d2, 0xd2}, {0x00d3, 0xd3}, {0x00d4, 0xd4}, {0x00d5, 0xd5}, {0x00d6, 0xd6}, {0x00d7, 0xd7},
+ {0x00d8, 0xd8}, {0x00d9, 0xd9}, {0x00da, 0xda}, {0x00db, 0xdb}, {0x00dc, 0xdc}, {0x00dd, 0xdd}, {0x00de, 0xde}, {0x00df, 0xdf},
+ {0x00e0, 0xe0}, {0x00e1, 0xe1}, {0x00e2, 0xe2}, {0x00e3, 0xe3}, {0x00e4, 0xe4}, {0x00e5, 0xe5}, {0x00e6, 0xe6}, {0x00e7, 0xe7},
+ {0x00e8, 0xe8}, {0x00e9, 0xe9}, {0x00ea, 0xea}, {0x00eb, 0xeb}, {0x00ec, 0xec}, {0x00ed, 0xed}, {0x00ee, 0xee}, {0x00ef, 0xef},
+ {0x00f0, 0xf0}, {0x00f1, 0xf1}, {0x00f2, 0xf2}, {0x00f3, 0xf3}, {0x00f4, 0xf4}, {0x00f5, 0xf5}, {0x00f6, 0xf6}, {0x00f7, 0xf7},
+ {0x00f8, 0xf8}, {0x00f9, 0xf9}, {0x00fa, 0xfa}, {0x00fb, 0xfb}, {0x00fc, 0xfc}, {0x00fd, 0xfd}, {0x00fe, 0xfe}, {0x00ff, 0xff},
+ };
+
+// This function extracts the next unicode code point from a stream of UTF-8
+// data.
+
+static size_t
+extract_next_code_point(const unsigned char *utf8,
+ const size_t /*length_in_bytes*/,
+ size_t &position)
+ {
+ long retval = -1;
+
+ long under_construction = 0;
+ int countdown = 0;
+ for(;;)
+ {
+ unsigned char ch = utf8[position++];
+ if( !(ch & 0x80) )
+ {
+ // We are in the ASCII subset of UTF-8
+ retval = ch;
+ break;
+ }
+ if( countdown == 0 )
+ {
+ // We have to be in byte1 of a UTF-8 conversion:
+ if( (ch & 0xE0) == 0xC0 )
+ {
+ // There is one byte to follow
+ countdown = 1;
+ under_construction = ch & 0x1F;
+ }
+ else if( (ch & 0xF0) == 0xE0 )
+ {
+ countdown = 2;
+ under_construction = ch & 0x0F;
+ }
+ else if( (ch & 0xF8) == 0xF0 )
+ {
+ countdown = 3;
+ under_construction = ch & 0x07;
+ }
+ else
+ {
+ // We have a poorly-constructed UTF-8 encoding
+ break;
+ }
+ }
+ else
+ {
+ // We are in a follow-up encoded byte:
+ if( (ch & 0xC0) == 0x80 )
+ {
+ // The top two bits are 10, so build in the bottom six bits
+ under_construction <<= 6;
+ under_construction |= (ch & 0x3F);
+ if( --countdown == 0 )
+ {
+ // We have processed all of the bytes of the encoded
+ // code point
+ retval = under_construction;
+ break;
+ }
+ }
+ else
+ {
+ // This is a poorly-formed encoding
+ break;
+ }
+ }
+ }
+
+ return retval;
+ }
+
+void flipper(void)
+ {
+ for(int i=0; i<256; i++)
+ {
+ fprintf(stderr, "{0x%4.4x, 0x%2.2x}, ", cp1252_to_utf8_values[i], i);
+ if( (i % 8) == 7 )
+ {
+ fprintf(stderr, "\n");
+ }
+ }
+ }
+
+extern "C"
+char __gg__ascii_to_ascii_chr(char ch)
+ {
+ return ch;
+ }
+
+extern "C"
+char __gg__ascii_to_ebcdic_chr(char ch)
+ {
+ return (char)__gg__cp1252_to_cp1140_values[(ch&0xFF)];
+ }
+
+
+extern "C"
+char *
+__gg__raw_to_ascii(const char *in, size_t length)
+ {
+ // A UTF-8 string is at least as long as the single-byte-coded resulting
+ // string:
+ char * const retval = (char *)malloc(length+1);
+ size_t index = 0;
+
+ size_t position = 0;
+ while( position < length )
+ {
+ size_t code_point;
+ // Pull the next code_point from the UTF-8 stream
+ long unicode_point = extract_next_code_point( (const unsigned char *)in,
+ length,
+ position );
+ if( unicode_point == -1 )
+ {
+ // The UTF-8 stream was poorly formed.
+ if( source_codeset == cs_utf8_auto_e )
+ {
+ //fprintf(stderr, "SWITCHING CODESETS!\n");
+ // This is a possibly contentious "solution" to the problem
+ // caused by the possibility that the source code that was
+ // processed by the compiler used a codeset differing from the
+ // one being used by the computer executing the resulting
+ // executable. In particular: if the target computer is using
+ // UTF-8 while the original source code was single-byte-coded.
+
+ // If we assume the source was UTF-8, but it has SBC characters
+ // above 127, they will likely show up as poorly-formed UTF-8.
+
+ // This can clearly be spoofed; there are valid strings of,
+ // say, CP1252 characters that form legitimate UTF-8 characters.
+
+ // But that is far less likely than the combination of source
+ // code produced in CP1252 being run on a UTF-8 system. This
+ // hack will produce a graceful solution to what I regard as the
+ // more likely occurrence without forcing the compile-time
+ // switches to know, ahead of time, the codeset of the target
+ // machine.
+ source_codeset = cs_cp1252_e;
+ free(retval);
+ return __gg__raw_to_ascii(in, length);
+ }
+ }
+
+ // Check for that unicode code point in the subset of characters we
+ // know about:
+ std::unordered_map<unsigned short, unsigned char>::const_iterator it =
+ utf8_to_cp1252_values.find(unicode_point);
+ if( it == utf8_to_cp1252_values.end() )
+ {
+ // That unicode character isn't in our list
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ code_point = it->second;
+ }
+ retval[index++] = (char)code_point;
+ }
+ retval[index++] = '\0';
+
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__raw_to_ebcdic(const char *in, size_t length)
+ {
+ // A UTF-8 string is at least as long as the single-byte-coded resulting
+ // string:
+ char * const retval = (char *)malloc(length+1);
+ size_t index = 0;
+
+ size_t position = 0;
+ while( position < length )
+ {
+ size_t code_point;
+ // Pull the next code_point from the UTF-8 stream
+ long unicode_point = extract_next_code_point( (const unsigned char *)in,
+ length,
+ position );
+ if( unicode_point == -1 )
+ {
+ // The UTF-8 stream was poorly formed.
+ if( source_codeset == cs_utf8_auto_e )
+ {
+ //fprintf(stderr, "SWITCHING CODESETS!\n");
+ // This is a possibly contentious "solution" to the problem
+ // caused by the possibility that the source code that was
+ // processed by the compiler used a codeset differing from the
+ // one being used by the computer executing the resulting
+ // executable. In particular: if the target computer is using
+ // UTF-8 while the original source code was single-byte-coded.
+
+ // If we assume the source was UTF-8, but it has SBC characters
+ // above 127, they will likely show up as poorly-formed UTF-8.
+
+ // This can clearly be spoofed; there are valid strings of,
+ // say, CP1252 characters that form legitimate UTF-8 characters.
+
+ // But that is far less likely than the combination of source
+ // code produced in CP1252 being run on a UTF-8 system. This
+ // hack will produce a graceful solution to what I regard as the
+ // more likely occurrence without forcing the compile-time
+ // switches to know, ahead of time, the codeset of the target
+ // machine.
+ source_codeset = cs_cp1252_e;
+ free(retval);
+ return __gg__raw_to_ebcdic(in, length);
+ }
+ }
+
+ // Check for that unicode code point in the subset of characters we
+ // know about:
+ std::unordered_map<unsigned short, unsigned char>::const_iterator it =
+ utf8_to_cp1252_values.find(unicode_point);
+ if( it == utf8_to_cp1252_values.end() )
+ {
+ // That unicode character isn't in our list
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ code_point = it->second;
+ }
+ // TODO: This could be sped up by creating a utf8_to_cp1140_values map.
+ // But sufficient unto the day are the evils thereof
+ long ebcdic_code_point = __gg__cp1252_to_cp1140_values[code_point&0xFF];
+ retval[index++] = ebcdic_code_point;
+ }
+ retval[index++] = '\0';
+
+ return retval;
+ }
+
+static
+char *
+convert_cp1252_to_utf8(const char *in, size_t length)
+ {
+ // Worst case is all unicode characters.
+ char * const retval = (char *)malloc(4 * length + 1);
+
+ size_t index = 0;
+ for(size_t i=0; i<length; i++)
+ {
+ unsigned char ch = *in++;
+ size_t unicode_point = cp1252_to_utf8_values[ch];
+ if( unicode_point < 0x0080 )
+ {
+ // Single-byte
+ retval[index++] = (char)unicode_point;
+ }
+ else if(unicode_point < 0x0800)
+ {
+ // Two-byte:
+ retval[index++] = 0xC0 + (unicode_point>>6);
+ retval[index++] = 0x80 + ((unicode_point>>0) & 0x3F);
+ }
+ else if(unicode_point < 0x10000)
+ {
+ // Three-byte:
+ retval[index++] = 0xE0 + (unicode_point>>12);
+ retval[index++] = 0x80 + ((unicode_point>>6) & 0x3F);
+ retval[index++] = 0x80 + ((unicode_point>>0) & 0x3F);
+ }
+ else
+ {
+ // Four-byte:
+ retval[index++] = 0xF0 + (unicode_point>>18);
+ retval[index++] = 0x80 + ((unicode_point>>12) & 0x3F);
+ retval[index++] = 0x80 + ((unicode_point>>6) & 0x3F);
+ retval[index++] = 0x80 + ((unicode_point>>0) & 0x3F);
+ }
+ }
+ retval[index++] = '\0';
+
+ return retval;
+ }
+
+// This is the address of the 256-character map for internal characters
+// It'll be set to one-to-one for ASCII, and to cp1252-to-cp1140_values for
+// EBCDIC.
+unsigned char const *__gg__internal_codeset_map;
+
+// Here is the list of function pointers establish which ones of the paired
+// possibilities of conversion routines are actually in use.
+
+char (*__gg__ascii_to_internal_chr)(char);
+void (*__gg__ascii_to_internal_str)(char *str, size_t length);
+char *(*__gg__raw_to_internal)(const char *in, const size_t length);
+char *(*__gg__internal_to_console_cm)(const char *in, size_t length);
+void (*__gg__console_to_internal_cm)(char * const str, size_t length);
+void (*__gg__internal_to_ascii)(char *str, size_t length);
+
+extern "C"
+void __gg__set_internal_codeset(int use_ebcdic)
+ {
+ __gg__ebcdic_codeset_in_use = !!use_ebcdic;
+ }
+
+extern "C"
+void __gg__text_conversion_override(text_device_t device,
+ text_codeset_t codeset)
+ {
+ // Establish the default sourcecode and console codesets, and
+ // establish the codeset conversion routines:
+
+ if( internal_is_ebcdic )
+ {
+// fprintf(stderr, "Setting up EBCDIC\n");
+ __gg__internal_codeset_map = __gg__cp1252_to_cp1140_values;
+ __gg__ascii_to_internal_chr = &__gg__ascii_to_ebcdic_chr;
+ __gg__ascii_to_internal_str = &__gg__ascii_to_ebcdic;
+ __gg__raw_to_internal = &__gg__raw_to_ebcdic;
+ __gg__internal_to_console_cm = &__gg__ebcdic_to_console;
+ __gg__console_to_internal_cm = &__gg__console_to_ebcdic;
+ __gg__internal_to_ascii = &__gg__ebcdic_to_ascii;
+ }
+ else
+ {
+// fprintf(stderr, "Setting up ASCII\n");
+ __gg__internal_codeset_map = __gg__one_to_one_values;
+ __gg__ascii_to_internal_chr = &__gg__ascii_to_ascii_chr;
+ __gg__ascii_to_internal_str = &__gg__ascii_to_ascii;
+ __gg__raw_to_internal = &__gg__raw_to_ascii;
+ __gg__internal_to_console_cm = &__gg__ascii_to_console;
+ __gg__console_to_internal_cm = &__gg__console_to_ascii;
+ __gg__internal_to_ascii = &__gg__ascii_to_ascii;
+ }
+
+ const char *system_codeset;
+ switch(device)
+ {
+ case td_default_e:
+ // We start by assuming everything is the machine's current locale
+ system_codeset = setlocale(0,"");
+ if( strstr(system_codeset, "UTF-8") )
+ {
+ source_codeset = cs_utf8_auto_e;
+ console_codeset = cs_utf8_e;
+ }
+ else
+ {
+ source_codeset = cs_cp1252_e;
+ console_codeset = cs_cp1252_e;
+ }
+ break;
+
+ case td_sourcecode_e:
+ source_codeset = codeset;
+ break;
+
+ case td_console_e:
+ console_codeset = codeset;
+ break;
+ }
+ }
+
+extern "C"
+void
+__gg__ascii_to_ascii(char *, size_t )
+ {
+ return;
+ }
+
+extern "C"
+void
+__gg__ascii_to_ebcdic(char *str, size_t length)
+ {
+ for(size_t i=0; i<length; i++)
+ {
+ str[i] = __gg__cp1252_to_cp1140_values[str[i]&0xFF];
+ }
+ }
+
+extern "C"
+void
+__gg__ebcdic_to_ascii(char * const str, size_t length)
+ {
+ for(size_t i=0; i<length; i++)
+ {
+ str[i] = __gg__cp1140_to_cp1252_values[str[i]&0xFF];
+ }
+ }
+
+extern "C"
+char *__gg__ascii_to_console(char const * const str, const size_t length)
+ {
+ char *retval = NULL;
+ if( console_codeset == cs_utf8_auto_e || console_codeset == cs_utf8_e )
+ {
+ retval = convert_cp1252_to_utf8(str, length);
+ }
+ else
+ {
+ retval = strdup(str);
+ }
+ return retval;
+ }
+
+extern "C"
+char *__gg__ebcdic_to_console(char const * const str, const size_t length)
+ {
+ char *retval = NULL;
+ char *ebcdic = (char *)malloc(length);
+ memcpy(ebcdic, str, length);
+ __gg__ebcdic_to_ascii(ebcdic, length);
+ if( console_codeset == cs_utf8_auto_e || console_codeset == cs_utf8_e )
+ {
+ retval = convert_cp1252_to_utf8(ebcdic, length);
+ }
+ else
+ {
+ retval = strdup(ebcdic);
+ }
+ free(ebcdic);
+ return retval;
+ }
+
+extern "C"
+void __gg__console_to_ascii(char * const str, size_t length)
+ {
+ // In-place conversion of ASCII data that might be UTF-8 to CP1252
+ if( console_codeset == cs_cp1252_e )
+ {
+ // It's already what we want it to be
+ return;
+ }
+ char *dest = str;
+
+ size_t position = 0;
+ while( position < length )
+ {
+ size_t code_point;
+ // Pull the next code_point from the UTF-8 stream
+ long unicode_point
+ = extract_next_code_point( (const unsigned char *)str,
+ length,
+ position );
+ if( unicode_point == -1 )
+ {
+ // The UTF-8 stream was poorly formed.
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ // Check for that unicode code point in the subset of characters we
+ // know about:
+ std::unordered_map<unsigned short, unsigned char>::const_iterator it
+ = utf8_to_cp1252_values.find(unicode_point);
+ if( it == utf8_to_cp1252_values.end() )
+ {
+ // That unicode character isn't in our list
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ code_point = it->second;
+ }
+ }
+ *dest++ = (char)code_point;
+ }
+ *dest++ = '\0';
+ }
+
+extern "C"
+void
+__gg__console_to_ebcdic(char * const str, size_t length)
+ {
+ char *dest = str;
+
+ size_t position = 0;
+ while( position < length )
+ {
+ size_t code_point;
+ // Pull the next code_point from the UTF-8 stream
+ long unicode_point
+ = extract_next_code_point( (const unsigned char *)str,
+ length,
+ position );
+ if( unicode_point == -1 )
+ {
+ // The UTF-8 stream was poorly formed.
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ // Check for that unicode code point in the subset of characters we
+ // know about:
+ std::unordered_map<unsigned short, unsigned char>::const_iterator it
+ = utf8_to_cp1252_values.find(unicode_point);
+ if( it == utf8_to_cp1252_values.end() )
+ {
+ // That unicode character isn't in our list
+ code_point = ASCII_REPLACEMENT;
+ }
+ else
+ {
+ code_point = it->second;
+ }
+ }
+ *dest++ = __gg__cp1252_to_cp1140_values[code_point&0xFF] ;
+ }
+ *dest++ = '\0';
+ }
diff --git a/libgcobol/class.c b/libgcobol/class.c
deleted file mode 100644
index 2ba5082f8fad..000000000000
--- a/libgcobol/class.c
+++ /dev/null
@@ -1,1007 +0,0 @@
-/* GNU Objective C Runtime class related functions
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup and Dennis Glatting.
-
- Lock-free class table code designed and written from scratch by
- Nicola Pero, 2001.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* The code in this file critically affects class method invocation
- speed. This long preamble comment explains why, and the issues
- involved.
-
- One of the traditional weaknesses of the GNU Objective-C runtime is
- that class method invocations are slow. The reason is that when you
- write
-
- array = [NSArray new];
-
- this gets basically compiled into the equivalent of
-
- array = [(objc_get_class ("NSArray")) new];
-
- objc_get_class returns the class pointer corresponding to the string
- `NSArray'; and because of the lookup, the operation is more
- complicated and slow than a simple instance method invocation.
-
- Most high performance Objective-C code (using the GNU Objc runtime)
- I had the opportunity to read (or write) work around this problem by
- caching the class pointer:
-
- Class arrayClass = [NSArray class];
-
- ... later on ...
-
- array = [arrayClass new];
- array = [arrayClass new];
- array = [arrayClass new];
-
- In this case, you always perform a class lookup (the first one), but
- then all the [arrayClass new] methods run exactly as fast as an
- instance method invocation. It helps if you have many class method
- invocations to the same class.
-
- The long-term solution to this problem would be to modify the
- compiler to output tables of class pointers corresponding to all the
- class method invocations, and to add code to the runtime to update
- these tables - that should in the end allow class method invocations
- to perform precisely as fast as instance method invocations, because
- no class lookup would be involved. I think the Apple Objective-C
- runtime uses this technique. Doing this involves synchronized
- modifications in the runtime and in the compiler.
-
- As a first medicine to the problem, I [NP] have redesigned and
- rewritten the way the runtime is performing class lookup. This
- doesn't give as much speed as the other (definitive) approach, but
- at least a class method invocation now takes approximately 4.5 times
- an instance method invocation on my machine (it would take approx 12
- times before the rewriting), which is a lot better.
-
- One of the main reason the new class lookup is so faster is because
- I implemented it in a way that can safely run multithreaded without
- using locks - a so-called `lock-free' data structure. The atomic
- operation is pointer assignment. The reason why in this problem
- lock-free data structures work so well is that you never remove
- classes from the table - and the difficult thing with lock-free data
- structures is freeing data when is removed from the structures. */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-#include "objc/runtime.h"
-#include "objc/thr.h"
-#include "objc-private/module-abi-8.h" /* For CLS_ISCLASS and similar. */
-#include "objc-private/runtime.h" /* the kitchen sink */
-#include "objc-private/sarray.h" /* For sarray_put_at_safe. */
-#include "objc-private/selector.h" /* For sarray_put_at_safe. */
-#include <string.h> /* For memset */
-
-/* We use a table which maps a class name to the corresponding class
- pointer. The first part of this file defines this table, and
- functions to do basic operations on the table. The second part of
- the file implements some higher level Objective-C functionality for
- classes by using the functions provided in the first part to manage
- the table. */
-
-/**
- ** Class Table Internals
- **/
-
-/* A node holding a class */
-typedef struct class_node
-{
- struct class_node *next; /* Pointer to next entry on the list.
- NULL indicates end of list. */
-
- const char *name; /* The class name string */
- int length; /* The class name string length */
- Class pointer; /* The Class pointer */
-
-} *class_node_ptr;
-
-/* A table containing classes is a class_node_ptr (pointing to the
- first entry in the table - if it is NULL, then the table is
- empty). */
-
-/* We have 1024 tables. Each table contains all class names which
- have the same hash (which is a number between 0 and 1023). To look
- up a class_name, we compute its hash, and get the corresponding
- table. Once we have the table, we simply compare strings directly
- till we find the one which we want (using the length first). The
- number of tables is quite big on purpose (a normal big application
- has less than 1000 classes), so that you shouldn't normally get any
- collisions, and get away with a single comparison (which we can't
- avoid since we need to know that you have got the right thing). */
-#define CLASS_TABLE_SIZE 1024
-#define CLASS_TABLE_MASK 1023
-
-static class_node_ptr class_table_array[CLASS_TABLE_SIZE];
-
-/* The table writing mutex - we lock on writing to avoid conflicts
- between different writers, but we read without locks. That is
- possible because we assume pointer assignment to be an atomic
- operation. TODO: This is only true under certain circumstances,
- which should be clarified. */
-static objc_mutex_t __class_table_lock = NULL;
-
-/* CLASS_TABLE_HASH is how we compute the hash of a class name. It is
- a macro - *not* a function - arguments *are* modified directly.
-
- INDEX should be a variable holding an int;
- HASH should be a variable holding an int;
- CLASS_NAME should be a variable holding a (char *) to the class_name.
-
- After the macro is executed, INDEX contains the length of the
- string, and HASH the computed hash of the string; CLASS_NAME is
- untouched. */
-
-#define CLASS_TABLE_HASH(INDEX, HASH, CLASS_NAME) \
- do { \
- HASH = 0; \
- for (INDEX = 0; CLASS_NAME[INDEX] != '\0'; INDEX++) \
- { \
- HASH = (HASH << 4) ^ (HASH >> 28) ^ CLASS_NAME[INDEX]; \
- } \
- \
- HASH = (HASH ^ (HASH >> 10) ^ (HASH >> 20)) & CLASS_TABLE_MASK; \
- } while (0)
-
-/* Setup the table. */
-static void
-class_table_setup (void)
-{
- /* Start - nothing in the table. */
- memset (class_table_array, 0, sizeof (class_node_ptr) * CLASS_TABLE_SIZE);
-
- /* The table writing mutex. */
- __class_table_lock = objc_mutex_allocate ();
-}
-
-
-/* Insert a class in the table (used when a new class is
- registered). */
-static void
-class_table_insert (const char *class_name, Class class_pointer)
-{
- int hash, length;
- class_node_ptr new_node;
-
- /* Find out the class name's hash and length. */
- CLASS_TABLE_HASH (length, hash, class_name);
-
- /* Prepare the new node holding the class. */
- new_node = objc_malloc (sizeof (struct class_node));
- new_node->name = class_name;
- new_node->length = length;
- new_node->pointer = class_pointer;
-
- /* Lock the table for modifications. */
- objc_mutex_lock (__class_table_lock);
-
- /* Insert the new node in the table at the beginning of the table at
- class_table_array[hash]. */
- new_node->next = class_table_array[hash];
- class_table_array[hash] = new_node;
-
- objc_mutex_unlock (__class_table_lock);
-}
-
-/* Get a class from the table. This does not need mutex protection.
- Currently, this function is called each time you call a static
- method, this is why it must be very fast. */
-static inline Class
-class_table_get_safe (const char *class_name)
-{
- class_node_ptr node;
- int length, hash;
-
- /* Compute length and hash. */
- CLASS_TABLE_HASH (length, hash, class_name);
-
- node = class_table_array[hash];
-
- if (node != NULL)
- {
- do
- {
- if (node->length == length)
- {
- /* Compare the class names. */
- int i;
-
- for (i = 0; i < length; i++)
- {
- if ((node->name)[i] != class_name[i])
- break;
- }
-
- if (i == length)
- {
- /* They are equal! */
- return node->pointer;
- }
- }
- }
- while ((node = node->next) != NULL);
- }
-
- return Nil;
-}
-
-/* Enumerate over the class table. */
-struct class_table_enumerator
-{
- int hash;
- class_node_ptr node;
-};
-
-
-static Class
-class_table_next (struct class_table_enumerator **e)
-{
- struct class_table_enumerator *enumerator = *e;
- class_node_ptr next;
-
- if (enumerator == NULL)
- {
- *e = objc_malloc (sizeof (struct class_table_enumerator));
- enumerator = *e;
- enumerator->hash = 0;
- enumerator->node = NULL;
-
- next = class_table_array[enumerator->hash];
- }
- else
- next = enumerator->node->next;
-
- if (next != NULL)
- {
- enumerator->node = next;
- return enumerator->node->pointer;
- }
- else
- {
- enumerator->hash++;
-
- while (enumerator->hash < CLASS_TABLE_SIZE)
- {
- next = class_table_array[enumerator->hash];
- if (next != NULL)
- {
- enumerator->node = next;
- return enumerator->node->pointer;
- }
- enumerator->hash++;
- }
-
- /* Ok - table finished - done. */
- objc_free (enumerator);
- return Nil;
- }
-}
-
-#if 0 /* DEBUGGING FUNCTIONS */
-/* Debugging function - print the class table. */
-void
-class_table_print (void)
-{
- int i;
-
- for (i = 0; i < CLASS_TABLE_SIZE; i++)
- {
- class_node_ptr node;
-
- printf ("%d:\n", i);
- node = class_table_array[i];
-
- while (node != NULL)
- {
- printf ("\t%s\n", node->name);
- node = node->next;
- }
- }
-}
-
-/* Debugging function - print an histogram of number of classes in
- function of hash key values. Useful to evaluate the hash function
- in real cases. */
-void
-class_table_print_histogram (void)
-{
- int i, j;
- int counter = 0;
-
- for (i = 0; i < CLASS_TABLE_SIZE; i++)
- {
- class_node_ptr node;
-
- node = class_table_array[i];
-
- while (node != NULL)
- {
- counter++;
- node = node->next;
- }
- if (((i + 1) % 50) == 0)
- {
- printf ("%4d:", i + 1);
- for (j = 0; j < counter; j++)
- printf ("X");
-
- printf ("\n");
- counter = 0;
- }
- }
- printf ("%4d:", i + 1);
- for (j = 0; j < counter; j++)
- printf ("X");
-
- printf ("\n");
-}
-#endif /* DEBUGGING FUNCTIONS */
-
-/**
- ** Objective-C runtime functions
- **/
-
-/* From now on, the only access to the class table data structure
- should be via the class_table_* functions. */
-
-/* This is a hook which is called by objc_get_class and
- objc_lookup_class if the runtime is not able to find the class.
- This may e.g. try to load in the class using dynamic loading.
-
- This hook was a public, global variable in the Traditional GNU
- Objective-C Runtime API (objc/objc-api.h). The modern GNU
- Objective-C Runtime API (objc/runtime.h) provides the
- objc_setGetUnknownClassHandler() function instead.
-*/
-Class (*_objc_lookup_class) (const char *name) = 0; /* !T:SAFE */
-
-/* The handler currently in use. PS: if both
- __obj_get_unknown_class_handler and _objc_lookup_class are defined,
- __objc_get_unknown_class_handler is called first. */
-static objc_get_unknown_class_handler
-__objc_get_unknown_class_handler = NULL;
-
-objc_get_unknown_class_handler
-objc_setGetUnknownClassHandler (objc_get_unknown_class_handler
- new_handler)
-{
- objc_get_unknown_class_handler old_handler
- = __objc_get_unknown_class_handler;
- __objc_get_unknown_class_handler = new_handler;
- return old_handler;
-}
-
-
-/* True when class links has been resolved. */
-BOOL __objc_class_links_resolved = NO; /* !T:UNUSED */
-
-
-void
-__objc_init_class_tables (void)
-{
- /* Allocate the class hash table. */
-
- if (__class_table_lock)
- return;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- class_table_setup ();
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* This function adds a class to the class hash table, and assigns the
- class a number, unless it's already known. Return 'YES' if the
- class was added. Return 'NO' if the class was already known. */
-BOOL
-__objc_add_class_to_hash (Class class)
-{
- Class existing_class;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Make sure the table is there. */
- assert (__class_table_lock);
-
- /* Make sure it's not a meta class. */
- assert (CLS_ISCLASS (class));
-
- /* Check to see if the class is already in the hash table. */
- existing_class = class_table_get_safe (class->name);
-
- if (existing_class)
- {
- objc_mutex_unlock (__objc_runtime_mutex);
- return NO;
- }
- else
- {
- /* The class isn't in the hash table. Add the class and assign
- a class number. */
- static unsigned int class_number = 1;
-
- CLS_SETNUMBER (class, class_number);
- CLS_SETNUMBER (class->class_pointer, class_number);
-
- ++class_number;
- class_table_insert (class->name, class);
-
- objc_mutex_unlock (__objc_runtime_mutex);
- return YES;
- }
-}
-
-Class
-objc_getClass (const char *name)
-{
- Class class;
-
- if (name == NULL)
- return Nil;
-
- class = class_table_get_safe (name);
-
- if (class)
- return class;
-
- if (__objc_get_unknown_class_handler)
- return (*__objc_get_unknown_class_handler) (name);
-
- if (_objc_lookup_class)
- return (*_objc_lookup_class) (name);
-
- return Nil;
-}
-
-Class
-objc_lookUpClass (const char *name)
-{
- if (name == NULL)
- return Nil;
- else
- return class_table_get_safe (name);
-}
-
-Class
-objc_getMetaClass (const char *name)
-{
- Class class = objc_getClass (name);
-
- if (class)
- return class->class_pointer;
- else
- return Nil;
-}
-
-Class
-objc_getRequiredClass (const char *name)
-{
- Class class = objc_getClass (name);
-
- if (class)
- return class;
- else
- _objc_abort ("objc_getRequiredClass ('%s') failed: class not found\n", name);
-}
-
-int
-objc_getClassList (Class *returnValue, int maxNumberOfClassesToReturn)
-{
- /* Iterate over all entries in the table. */
- int hash, count = 0;
-
- for (hash = 0; hash < CLASS_TABLE_SIZE; hash++)
- {
- class_node_ptr node = class_table_array[hash];
-
- while (node != NULL)
- {
- if (returnValue)
- {
- if (count < maxNumberOfClassesToReturn)
- returnValue[count] = node->pointer;
- else
- return count;
- }
- count++;
- node = node->next;
- }
- }
-
- return count;
-}
-
-Class
-objc_allocateClassPair (Class super_class, const char *class_name, size_t extraBytes)
-{
- Class new_class;
- Class new_meta_class;
-
- if (class_name == NULL)
- return Nil;
-
- if (objc_getClass (class_name))
- return Nil;
-
- if (super_class)
- {
- /* If you want to build a hierarchy of classes, you need to
- build and register them one at a time. The risk is that you
- are able to cause confusion by registering a subclass before
- the superclass or similar. */
- if (CLS_IS_IN_CONSTRUCTION (super_class))
- return Nil;
- }
-
- /* Technically, we should create the metaclass first, then use
- class_createInstance() to create the class. That complication
- would be relevant if we had class variables, but we don't, so we
- just ignore it and create everything directly and assume all
- classes have the same size. */
- new_class = objc_calloc (1, sizeof (struct objc_class) + extraBytes);
- new_meta_class = objc_calloc (1, sizeof (struct objc_class) + extraBytes);
-
- /* We create an unresolved class, similar to one generated by the
- compiler. It will be resolved later when we register it.
-
- Note how the metaclass details are not that important; when the
- class is resolved, the ones that matter will be fixed up. */
- new_class->class_pointer = new_meta_class;
- new_meta_class->class_pointer = 0;
-
- if (super_class)
- {
- /* Force the name of the superclass in place of the link to the
- actual superclass, which will be put there when the class is
- resolved. */
- const char *super_class_name = class_getName (super_class);
- new_class->super_class = (void *)super_class_name;
- new_meta_class->super_class = (void *)super_class_name;
- }
- else
- {
- new_class->super_class = (void *)0;
- new_meta_class->super_class = (void *)0;
- }
-
- new_class->name = objc_malloc (strlen (class_name) + 1);
- strcpy ((char*)new_class->name, class_name);
- new_meta_class->name = new_class->name;
-
- new_class->version = 0;
- new_meta_class->version = 0;
-
- new_class->info = _CLS_CLASS | _CLS_IN_CONSTRUCTION;
- new_meta_class->info = _CLS_META | _CLS_IN_CONSTRUCTION;
-
- if (super_class)
- new_class->instance_size = super_class->instance_size;
- else
- new_class->instance_size = 0;
- new_meta_class->instance_size = sizeof (struct objc_class);
-
- return new_class;
-}
-
-void
-objc_registerClassPair (Class class_)
-{
- if (class_ == Nil)
- return;
-
- if ((! CLS_ISCLASS (class_)) || (! CLS_IS_IN_CONSTRUCTION (class_)))
- return;
-
- if ((! CLS_ISMETA (class_->class_pointer)) || (! CLS_IS_IN_CONSTRUCTION (class_->class_pointer)))
- return;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- if (objc_getClass (class_->name))
- {
- objc_mutex_unlock (__objc_runtime_mutex);
- return;
- }
-
- CLS_SET_NOT_IN_CONSTRUCTION (class_);
- CLS_SET_NOT_IN_CONSTRUCTION (class_->class_pointer);
-
- __objc_init_class (class_);
-
- /* Resolve class links immediately. No point in waiting. */
- __objc_resolve_class_links ();
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-void
-objc_disposeClassPair (Class class_)
-{
- if (class_ == Nil)
- return;
-
- if ((! CLS_ISCLASS (class_)) || (! CLS_IS_IN_CONSTRUCTION (class_)))
- return;
-
- if ((! CLS_ISMETA (class_->class_pointer)) || (! CLS_IS_IN_CONSTRUCTION (class_->class_pointer)))
- return;
-
- /* Undo any class_addIvar(). */
- if (class_->ivars)
- {
- int i;
- for (i = 0; i < class_->ivars->ivar_count; i++)
- {
- struct objc_ivar *ivar = &(class_->ivars->ivar_list[i]);
-
- objc_free ((char *)ivar->ivar_name);
- objc_free ((char *)ivar->ivar_type);
- }
-
- objc_free (class_->ivars);
- }
-
- /* Undo any class_addMethod(). */
- if (class_->methods)
- {
- struct objc_method_list *list = class_->methods;
- while (list)
- {
- int i;
- struct objc_method_list *next = list->method_next;
-
- for (i = 0; i < list->method_count; i++)
- {
- struct objc_method *method = &(list->method_list[i]);
-
- objc_free ((char *)method->method_name);
- objc_free ((char *)method->method_types);
- }
-
- objc_free (list);
- list = next;
- }
- }
-
- /* Undo any class_addProtocol(). */
- if (class_->protocols)
- {
- struct objc_protocol_list *list = class_->protocols;
- while (list)
- {
- struct objc_protocol_list *next = list->next;
-
- objc_free (list);
- list = next;
- }
- }
-
- /* Undo any class_addMethod() on the meta-class. */
- if (class_->class_pointer->methods)
- {
- struct objc_method_list *list = class_->class_pointer->methods;
- while (list)
- {
- int i;
- struct objc_method_list *next = list->method_next;
-
- for (i = 0; i < list->method_count; i++)
- {
- struct objc_method *method = &(list->method_list[i]);
-
- objc_free ((char *)method->method_name);
- objc_free ((char *)method->method_types);
- }
-
- objc_free (list);
- list = next;
- }
- }
-
- /* Undo objc_allocateClassPair(). */
- objc_free ((char *)(class_->name));
- objc_free (class_->class_pointer);
- objc_free (class_);
-}
-
-/* Traditional GNU Objective-C Runtime API. Important: this method is
- called automatically by the compiler while messaging (if using the
- traditional ABI), so it is worth keeping it fast; don't make it
- just a wrapper around objc_getClass(). */
-/* Note that this is roughly equivalent to objc_getRequiredClass(). */
-/* Get the class object for the class named NAME. If NAME does not
- identify a known class, the hook _objc_lookup_class is called. If
- this fails, an error message is issued and the system aborts. */
-Class
-objc_get_class (const char *name)
-{
- Class class;
-
- class = class_table_get_safe (name);
-
- if (class)
- return class;
-
- if (__objc_get_unknown_class_handler)
- class = (*__objc_get_unknown_class_handler) (name);
-
- if ((!class) && _objc_lookup_class)
- class = (*_objc_lookup_class) (name);
-
- if (class)
- return class;
-
- _objc_abort ("objc runtime: cannot find class %s\n", name);
-
- return 0;
-}
-
-/* This is used by the compiler too. */
-Class
-objc_get_meta_class (const char *name)
-{
- return objc_get_class (name)->class_pointer;
-}
-
-/* This is not used by GCC, but the clang compiler seems to use it
- when targeting the GNU runtime. That's wrong, but we have it to
- be compatible. */
-Class
-objc_lookup_class (const char *name)
-{
- return objc_getClass (name);
-}
-
-/* This is used when the implementation of a method changes. It goes
- through all classes, looking for the ones that have these methods
- (either method_a or method_b; method_b can be NULL), and reloads
- the implementation for these. You should call this with the
- runtime mutex already locked. */
-void
-__objc_update_classes_with_methods (struct objc_method *method_a, struct objc_method *method_b)
-{
- int hash;
-
- /* Iterate over all classes. */
- for (hash = 0; hash < CLASS_TABLE_SIZE; hash++)
- {
- class_node_ptr node = class_table_array[hash];
-
- while (node != NULL)
- {
- /* We execute this loop twice: the first time, we iterate
- over all methods in the class (instance methods), while
- the second time we iterate over all methods in the meta
- class (class methods). */
- Class class = Nil;
- BOOL done = NO;
-
- while (done == NO)
- {
- struct objc_method_list * method_list;
-
- if (class == Nil)
- {
- /* The first time, we work on the class. */
- class = node->pointer;
- }
- else
- {
- /* The second time, we work on the meta class. */
- class = class->class_pointer;
- done = YES;
- }
-
- method_list = class->methods;
-
- while (method_list)
- {
- int i;
-
- for (i = 0; i < method_list->method_count; ++i)
- {
- struct objc_method *method = &method_list->method_list[i];
-
- /* If the method is one of the ones we are
- looking for, update the implementation. */
- if (method == method_a)
- sarray_at_put_safe (class->dtable,
- (sidx) method_a->method_name->sel_id,
- method_a->method_imp);
-
- if (method == method_b)
- {
- if (method_b != NULL)
- sarray_at_put_safe (class->dtable,
- (sidx) method_b->method_name->sel_id,
- method_b->method_imp);
- }
- }
-
- method_list = method_list->method_next;
- }
- }
- node = node->next;
- }
- }
-}
-
-/* Resolve super/subclass links for all classes. The only thing we
- can be sure of is that the class_pointer for class objects point to
- the right meta class objects. */
-void
-__objc_resolve_class_links (void)
-{
- struct class_table_enumerator *es = NULL;
- Class object_class = objc_get_class ("Object");
- Class class1;
-
- assert (object_class);
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Assign subclass links. */
- while ((class1 = class_table_next (&es)))
- {
- /* Make sure we have what we think we have. */
- assert (CLS_ISCLASS (class1));
- assert (CLS_ISMETA (class1->class_pointer));
-
- /* The class_pointer of all meta classes point to Object's meta
- class. */
- class1->class_pointer->class_pointer = object_class->class_pointer;
-
- if (! CLS_ISRESOLV (class1))
- {
- CLS_SETRESOLV (class1);
- CLS_SETRESOLV (class1->class_pointer);
-
- if (class1->super_class)
- {
- Class a_super_class
- = objc_get_class ((char *) class1->super_class);
-
- assert (a_super_class);
-
- DEBUG_PRINTF ("making class connections for: %s\n",
- class1->name);
-
- /* Assign subclass links for superclass. */
- class1->sibling_class = a_super_class->subclass_list;
- a_super_class->subclass_list = class1;
-
- /* Assign subclass links for meta class of superclass. */
- if (a_super_class->class_pointer)
- {
- class1->class_pointer->sibling_class
- = a_super_class->class_pointer->subclass_list;
- a_super_class->class_pointer->subclass_list
- = class1->class_pointer;
- }
- }
- else /* A root class, make its meta object be a subclass of
- Object. */
- {
- class1->class_pointer->sibling_class
- = object_class->subclass_list;
- object_class->subclass_list = class1->class_pointer;
- }
- }
- }
-
- /* Assign superclass links. */
- es = NULL;
- while ((class1 = class_table_next (&es)))
- {
- Class sub_class;
- for (sub_class = class1->subclass_list; sub_class;
- sub_class = sub_class->sibling_class)
- {
- sub_class->super_class = class1;
- if (CLS_ISCLASS (sub_class))
- sub_class->class_pointer->super_class = class1->class_pointer;
- }
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-const char *
-class_getName (Class class_)
-{
- if (class_ == Nil)
- return "nil";
-
- return class_->name;
-}
-
-BOOL
-class_isMetaClass (Class class_)
-{
- /* CLS_ISMETA includes the check for Nil class_. */
- return CLS_ISMETA (class_);
-}
-
-/* Even inside libobjc it may be worth using class_getSuperclass
- instead of accessing class_->super_class directly because it
- resolves the class links if needed. If you access
- class_->super_class directly, make sure to deal with the situation
- where the class is not resolved yet! */
-Class
-class_getSuperclass (Class class_)
-{
- if (class_ == Nil)
- return Nil;
-
- /* Classes that are in construction are not resolved, and still have
- the class name (instead of a class pointer) in the
- class_->super_class field. In that case we need to lookup the
- superclass name to return the superclass. We cannot resolve the
- class until it is registered. */
- if (CLS_IS_IN_CONSTRUCTION (class_))
- {
- if (CLS_ISMETA (class_))
- return object_getClass ((id)objc_lookUpClass ((const char *)(class_->super_class)));
- else
- return objc_lookUpClass ((const char *)(class_->super_class));
- }
-
- /* If the class is not resolved yet, super_class would point to a
- string (the name of the super class) as opposed to the actual
- super class. In that case, we need to resolve the class links
- before we can return super_class. */
- if (! CLS_ISRESOLV (class_))
- __objc_resolve_class_links ();
-
- return class_->super_class;
-}
-
-int
-class_getVersion (Class class_)
-{
- if (class_ == Nil)
- return 0;
-
- return (int)(class_->version);
-}
-
-void
-class_setVersion (Class class_, int version)
-{
- if (class_ == Nil)
- return;
-
- class_->version = version;
-}
-
-size_t
-class_getInstanceSize (Class class_)
-{
- if (class_ == Nil)
- return 0;
-
- return class_->instance_size;
-}
-
diff --git a/libgcobol/configure b/libgcobol/configure
index 1a874985381f..3003002c7e08 100755
--- a/libgcobol/configure
+++ b/libgcobol/configure
@@ -592,7 +592,6 @@ PACKAGE_STRING='package-unused version-unused'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''
-ac_unique_file="objc/objc.h"
# Factoring default headers for most tests.
ac_includes_default="\
#include <stdio.h>
@@ -2217,7 +2216,6 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
ac_aux_dir=
for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do
if test -f "$ac_dir/install-sh"; then
@@ -10771,7 +10769,7 @@ else
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 10774 "configure"
+#line 10772 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
@@ -10877,7 +10875,7 @@ else
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 10880 "configure"
+#line 10878 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
diff --git a/libgcobol/configure.ac b/libgcobol/configure.ac
index ff2c1a83e090..497cc0dc5b02 100644
--- a/libgcobol/configure.ac
+++ b/libgcobol/configure.ac
@@ -19,7 +19,6 @@
#<http://www.gnu.org/licenses/>.
AC_INIT(package-unused, version-unused,, libgcobol)
-AC_CONFIG_SRCDIR([objc/objc.h])
GCC_TOPLEV_SUBDIRS
# We need the following definitions because AC_PROG_LIBTOOL relies on them
diff --git a/libgcobol/encoding.c b/libgcobol/encoding.c
deleted file mode 100644
index 77d88866a4e1..000000000000
--- a/libgcobol/encoding.c
+++ /dev/null
@@ -1,1267 +0,0 @@
-/* Encoding of types for Objective C.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
- Bitfield support by Ovidiu Predescu
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* FIXME: This file has no business including tm.h. */
-
-/* FIXME: This file contains functions that will abort the entire
- program if they fail. Is that really needed ? */
-
-#include "config.h"
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-#include "tconfig.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h" /* For struct objc_method */
-#include <stdlib.h>
-#include <ctype.h>
-#include <string.h> /* For memcpy. */
-
-#undef MAX
-#define MAX(X, Y) \
- ({ typeof (X) __x = (X), __y = (Y); \
- (__x > __y ? __x : __y); })
-
-#undef MIN
-#define MIN(X, Y) \
- ({ typeof (X) __x = (X), __y = (Y); \
- (__x < __y ? __x : __y); })
-
-#undef ROUND
-#define ROUND(V, A) \
- ({ typeof (V) __v = (V); typeof (A) __a = (A); \
- __a * ((__v+__a - 1)/__a); })
-
-
-/* Various hacks for objc_layout_record. These are used by the target
- macros. */
-
-#define TREE_CODE(TYPE) *(TYPE)
-#define TREE_TYPE(TREE) (TREE)
-
-#define RECORD_TYPE _C_STRUCT_B
-#define UNION_TYPE _C_UNION_B
-#define QUAL_UNION_TYPE _C_UNION_B
-#define ARRAY_TYPE _C_ARY_B
-
-#define REAL_TYPE _C_DBL
-
-#define VECTOR_TYPE _C_VECTOR
-
-#define TYPE_FIELDS(TYPE) ({const char *_field = (TYPE)+1; \
- while (*_field != _C_STRUCT_E && *_field != _C_STRUCT_B \
- && *_field != _C_UNION_B && *_field++ != '=') \
- /* do nothing */; \
- _field;})
-
-#define DECL_MODE(TYPE) *(TYPE)
-#define TYPE_MODE(TYPE) *(TYPE)
-
-#undef DFmode
-#define DFmode _C_DBL
-
-#define strip_array_types(TYPE) ({const char *_field = (TYPE); \
- while (*_field == _C_ARY_B)\
- {\
- while (isdigit ((unsigned char)*++_field))\
- ;\
- }\
- _field;})
-
-/* Some ports (eg ARM) allow the structure size boundary to be
- selected at compile-time. We override the normal definition with
- one that has a constant value for this compilation. */
-#undef STRUCTURE_SIZE_BOUNDARY
-#define STRUCTURE_SIZE_BOUNDARY (__CHAR_BIT__ * sizeof (struct{char a;}))
-
-/* Some ROUND_TYPE_ALIGN macros use TARGET_foo, and consequently
- target_flags. Define a dummy entry here to so we don't die.
- We have to rename it because target_flags may already have been
- declared extern. */
-#define target_flags not_target_flags
-static int __attribute__ ((__unused__)) not_target_flags = 0;
-
-/* Some ROUND_TYPE_ALIGN use ALTIVEC_VECTOR_MODE (rs6000 darwin).
- Define a dummy ALTIVEC_VECTOR_MODE so it will not die. */
-#undef ALTIVEC_VECTOR_MODE
-#define ALTIVEC_VECTOR_MODE(MODE) (0)
-
-/* Replace TARGET_VSX, TARGET_ALTIVEC, and TARGET_64BIT with constants based on
- the current switches, rather than looking in the options structure. */
-#ifdef _ARCH_PPC
-#undef TARGET_VSX
-#undef TARGET_ALTIVEC
-#undef TARGET_64BIT
-
-#ifdef __VSX__
-#define TARGET_VSX 1
-#else
-#define TARGET_VSX 0
-#endif
-
-#ifdef __ALTIVEC__
-#define TARGET_ALTIVEC 1
-#else
-#define TARGET_ALTIVEC 0
-#endif
-
-#ifdef _ARCH_PPC64
-#define TARGET_64BIT 1
-#else
-#define TARGET_64BIT 0
-#endif
-#endif
-
-/* Furthermore, some (powerpc) targets also use TARGET_ALIGN_NATURAL
- in their alignment macros. Currently[4.5/6], rs6000.h points this
- to a static variable, initialized by target overrides. This is reset
- in linux64.h but not in darwin64.h. The macro is not used by *86*. */
-
-#if __MACH__
-# if __LP64__
-# undef TARGET_ALIGN_NATURAL
-# define TARGET_ALIGN_NATURAL 1
-# endif
-/* On Darwin32, we need to recurse until we find the starting stuct type. */
-static int
-_darwin_rs6000_special_round_type_align (const char *struc, int comp, int spec)
-{
- const char *_stp , *_fields = TYPE_FIELDS (struc);
- if (!_fields)
- return MAX (comp, spec);
- _stp = strip_array_types (_fields);
- if (TYPE_MODE(_stp) == _C_COMPLEX)
- _stp++;
- switch (TYPE_MODE(_stp))
- {
- case RECORD_TYPE:
- case UNION_TYPE:
- return MAX (MAX (comp, spec), objc_alignof_type (_stp) * __CHAR_BIT__);
- break;
- case DFmode:
- case _C_LNG_LNG:
- case _C_ULNG_LNG:
- return MAX (MAX (comp, spec), 64);
- break;
-
- default:
- return MAX (comp, spec);
- break;
- }
-}
-
-/* See comment below. */
-#define darwin_rs6000_special_round_type_align(S,C,S2) \
- (_darwin_rs6000_special_round_type_align ((char*)(S), (int)(C), (int)(S2)))
-#endif
-
-/* FIXME: while this file has no business including tm.h, this
- definitely has no business defining this macro but it
- is only way around without really rewritting this file,
- should look after the branch of 3.4 to fix this. */
-#define rs6000_special_round_type_align(STRUCT, COMPUTED, SPECIFIED) \
- ({ const char *_fields = TYPE_FIELDS (STRUCT); \
- ((_fields != 0 \
- && TYPE_MODE (strip_array_types (TREE_TYPE (_fields))) == DFmode) \
- ? MAX (MAX (COMPUTED, SPECIFIED), 64) \
- : MAX (COMPUTED, SPECIFIED));})
-
-#define rs6000_special_adjust_field_align_p(FIELD, COMPUTED) 0
-
-/* Skip a variable name, enclosed in quotes ("). */
-static inline
-const char *
-objc_skip_variable_name (const char *type)
-{
- /* Skip the variable name if any. */
- if (*type == '"')
- {
- /* FIXME: How do we know we won't read beyond the end of the
- string. Here and in the rest of the file! */
- /* Skip '"'. */
- type++;
- /* Skip to the next '"'. */
- while (*type != '"')
- type++;
- /* Skip '"'. */
- type++;
- }
-
- return type;
-}
-
-int
-objc_sizeof_type (const char *type)
-{
- type = objc_skip_variable_name (type);
-
- switch (*type) {
- case _C_BOOL:
- return sizeof (_Bool);
- break;
-
- case _C_ID:
- return sizeof (id);
- break;
-
- case _C_CLASS:
- return sizeof (Class);
- break;
-
- case _C_SEL:
- return sizeof (SEL);
- break;
-
- case _C_CHR:
- return sizeof (char);
- break;
-
- case _C_UCHR:
- return sizeof (unsigned char);
- break;
-
- case _C_SHT:
- return sizeof (short);
- break;
-
- case _C_USHT:
- return sizeof (unsigned short);
- break;
-
- case _C_INT:
- return sizeof (int);
- break;
-
- case _C_UINT:
- return sizeof (unsigned int);
- break;
-
- case _C_LNG:
- return sizeof (long);
- break;
-
- case _C_ULNG:
- return sizeof (unsigned long);
- break;
-
- case _C_LNG_LNG:
- return sizeof (long long);
- break;
-
- case _C_ULNG_LNG:
- return sizeof (unsigned long long);
- break;
-
- case _C_FLT:
- return sizeof (float);
- break;
-
- case _C_DBL:
- return sizeof (double);
- break;
-
- case _C_LNG_DBL:
- return sizeof (long double);
- break;
-
- case _C_VOID:
- return sizeof (void);
- break;
-
- case _C_PTR:
- case _C_ATOM:
- case _C_CHARPTR:
- return sizeof (char *);
- break;
-
- case _C_ARY_B:
- {
- int len = atoi (type + 1);
- while (isdigit ((unsigned char)*++type))
- ;
- return len * objc_aligned_size (type);
- }
- break;
-
- case _C_VECTOR:
- {
- /* Skip the '!'. */
- type++;
- /* Skip the '['. */
- type++;
-
- /* The size in bytes is the following number. */
- int size = atoi (type);
- return size;
- }
- break;
-
- case _C_BFLD:
- {
- /* The GNU encoding of bitfields is: b 'position' 'type'
- 'size'. */
- int position, size;
- int startByte, endByte;
-
- position = atoi (type + 1);
- while (isdigit ((unsigned char)*++type))
- ;
- size = atoi (type + 1);
-
- startByte = position / __CHAR_BIT__;
- endByte = (position + size) / __CHAR_BIT__;
- return endByte - startByte;
- }
-
- case _C_UNION_B:
- case _C_STRUCT_B:
- {
- struct objc_struct_layout layout;
- unsigned int size;
-
- objc_layout_structure (type, &layout);
- while (objc_layout_structure_next_member (&layout))
- /* do nothing */ ;
- objc_layout_finish_structure (&layout, &size, NULL);
-
- return size;
- }
-
- case _C_COMPLEX:
- {
- type++; /* Skip after the 'j'. */
- switch (*type)
- {
- case _C_CHR:
- return sizeof (_Complex char);
- break;
-
- case _C_UCHR:
- return sizeof (_Complex unsigned char);
- break;
-
- case _C_SHT:
- return sizeof (_Complex short);
- break;
-
- case _C_USHT:
- return sizeof (_Complex unsigned short);
- break;
-
- case _C_INT:
- return sizeof (_Complex int);
- break;
-
- case _C_UINT:
- return sizeof (_Complex unsigned int);
- break;
-
- case _C_LNG:
- return sizeof (_Complex long);
- break;
-
- case _C_ULNG:
- return sizeof (_Complex unsigned long);
- break;
-
- case _C_LNG_LNG:
- return sizeof (_Complex long long);
- break;
-
- case _C_ULNG_LNG:
- return sizeof (_Complex unsigned long long);
- break;
-
- case _C_FLT:
- return sizeof (_Complex float);
- break;
-
- case _C_DBL:
- return sizeof (_Complex double);
- break;
-
- case _C_LNG_DBL:
- return sizeof (_Complex long double);
- break;
-
- default:
- {
- /* FIXME: Is this so bad that we have to abort the
- entire program ? (it applies to all the other
- _objc_abort calls in this file).
- */
- _objc_abort ("unknown complex type %s\n", type);
- return 0;
- }
- }
- }
-
- default:
- {
- _objc_abort ("unknown type %s\n", type);
- return 0;
- }
- }
-}
-
-int
-objc_alignof_type (const char *type)
-{
- type = objc_skip_variable_name (type);
-
- switch (*type) {
- case _C_BOOL:
- return __alignof__ (_Bool);
- break;
-
- case _C_ID:
- return __alignof__ (id);
- break;
-
- case _C_CLASS:
- return __alignof__ (Class);
- break;
-
- case _C_SEL:
- return __alignof__ (SEL);
- break;
-
- case _C_CHR:
- return __alignof__ (char);
- break;
-
- case _C_UCHR:
- return __alignof__ (unsigned char);
- break;
-
- case _C_SHT:
- return __alignof__ (short);
- break;
-
- case _C_USHT:
- return __alignof__ (unsigned short);
- break;
-
- case _C_INT:
- return __alignof__ (int);
- break;
-
- case _C_UINT:
- return __alignof__ (unsigned int);
- break;
-
- case _C_LNG:
- return __alignof__ (long);
- break;
-
- case _C_ULNG:
- return __alignof__ (unsigned long);
- break;
-
- case _C_LNG_LNG:
- return __alignof__ (long long);
- break;
-
- case _C_ULNG_LNG:
- return __alignof__ (unsigned long long);
- break;
-
- case _C_FLT:
- return __alignof__ (float);
- break;
-
- case _C_DBL:
- return __alignof__ (double);
- break;
-
- case _C_LNG_DBL:
- return __alignof__ (long double);
- break;
-
- case _C_PTR:
- case _C_ATOM:
- case _C_CHARPTR:
- return __alignof__ (char *);
- break;
-
- case _C_ARY_B:
- while (isdigit ((unsigned char)*++type))
- /* do nothing */;
- return objc_alignof_type (type);
-
- case _C_VECTOR:
- {
- /* Skip the '!'. */
- type++;
- /* Skip the '['. */
- type++;
-
- /* Skip the size. */
- while (isdigit ((unsigned char)*type))
- type++;
-
- /* Skip the ','. */
- type++;
-
- /* The alignment in bytes is the following number. */
- return atoi (type);
- }
- case _C_STRUCT_B:
- case _C_UNION_B:
- {
- struct objc_struct_layout layout;
- unsigned int align;
-
- objc_layout_structure (type, &layout);
- while (objc_layout_structure_next_member (&layout))
- /* do nothing */;
- objc_layout_finish_structure (&layout, NULL, &align);
-
- return align;
- }
-
-
- case _C_COMPLEX:
- {
- type++; /* Skip after the 'j'. */
- switch (*type)
- {
- case _C_CHR:
- return __alignof__ (_Complex char);
- break;
-
- case _C_UCHR:
- return __alignof__ (_Complex unsigned char);
- break;
-
- case _C_SHT:
- return __alignof__ (_Complex short);
- break;
-
- case _C_USHT:
- return __alignof__ (_Complex unsigned short);
- break;
-
- case _C_INT:
- return __alignof__ (_Complex int);
- break;
-
- case _C_UINT:
- return __alignof__ (_Complex unsigned int);
- break;
-
- case _C_LNG:
- return __alignof__ (_Complex long);
- break;
-
- case _C_ULNG:
- return __alignof__ (_Complex unsigned long);
- break;
-
- case _C_LNG_LNG:
- return __alignof__ (_Complex long long);
- break;
-
- case _C_ULNG_LNG:
- return __alignof__ (_Complex unsigned long long);
- break;
-
- case _C_FLT:
- return __alignof__ (_Complex float);
- break;
-
- case _C_DBL:
- return __alignof__ (_Complex double);
- break;
-
- case _C_LNG_DBL:
- return __alignof__ (_Complex long double);
- break;
-
- default:
- {
- _objc_abort ("unknown complex type %s\n", type);
- return 0;
- }
- }
- }
-
- default:
- {
- _objc_abort ("unknown type %s\n", type);
- return 0;
- }
- }
-}
-
-int
-objc_aligned_size (const char *type)
-{
- int size, align;
-
- type = objc_skip_variable_name (type);
- size = objc_sizeof_type (type);
- align = objc_alignof_type (type);
-
- return ROUND (size, align);
-}
-
-int
-objc_promoted_size (const char *type)
-{
- int size, wordsize;
-
- type = objc_skip_variable_name (type);
- size = objc_sizeof_type (type);
- wordsize = sizeof (void *);
-
- return ROUND (size, wordsize);
-}
-
-inline
-const char *
-objc_skip_type_qualifiers (const char *type)
-{
- while (*type == _C_CONST
- || *type == _C_IN
- || *type == _C_INOUT
- || *type == _C_OUT
- || *type == _C_BYCOPY
- || *type == _C_BYREF
- || *type == _C_ONEWAY
- || *type == _C_GCINVISIBLE)
- {
- type += 1;
- }
- return type;
-}
-
-inline
-const char *
-objc_skip_typespec (const char *type)
-{
- type = objc_skip_variable_name (type);
- type = objc_skip_type_qualifiers (type);
-
- switch (*type) {
-
- case _C_ID:
- /* An id may be annotated by the actual type if it is known
- with the @"ClassName" syntax */
-
- if (*++type != '"')
- return type;
- else
- {
- while (*++type != '"')
- /* do nothing */;
- return type + 1;
- }
-
- /* The following are one character type codes */
- case _C_CLASS:
- case _C_SEL:
- case _C_CHR:
- case _C_UCHR:
- case _C_CHARPTR:
- case _C_ATOM:
- case _C_SHT:
- case _C_USHT:
- case _C_INT:
- case _C_UINT:
- case _C_LNG:
- case _C_BOOL:
- case _C_ULNG:
- case _C_LNG_LNG:
- case _C_ULNG_LNG:
- case _C_FLT:
- case _C_DBL:
- case _C_LNG_DBL:
- case _C_VOID:
- case _C_UNDEF:
- return ++type;
- break;
-
- case _C_COMPLEX:
- return type + 2;
- break;
-
- case _C_ARY_B:
- /* skip digits, typespec and closing ']' */
- while (isdigit ((unsigned char)*++type))
- ;
- type = objc_skip_typespec (type);
- if (*type == _C_ARY_E)
- return ++type;
- else
- {
- _objc_abort ("bad array type %s\n", type);
- return 0;
- }
-
- case _C_VECTOR:
- /* Skip '!' */
- type++;
- /* Skip '[' */
- type++;
- /* Skip digits (size) */
- while (isdigit ((unsigned char)*type))
- type++;
- /* Skip ',' */
- type++;
- /* Skip digits (alignment) */
- while (isdigit ((unsigned char)*type))
- type++;
- /* Skip typespec. */
- type = objc_skip_typespec (type);
- /* Skip closing ']'. */
- if (*type == _C_ARY_E)
- return ++type;
- else
- {
- _objc_abort ("bad vector type %s\n", type);
- return 0;
- }
-
- case _C_BFLD:
- /* The GNU encoding of bitfields is: b 'position' 'type'
- 'size'. */
- while (isdigit ((unsigned char)*++type))
- ; /* skip position */
- while (isdigit ((unsigned char)*++type))
- ; /* skip type and size */
- return type;
-
- case _C_STRUCT_B:
- /* skip name, and elements until closing '}' */
-
- while (*type != _C_STRUCT_E && *type++ != '=')
- ;
- while (*type != _C_STRUCT_E)
- {
- type = objc_skip_typespec (type);
- }
- return ++type;
-
- case _C_UNION_B:
- /* skip name, and elements until closing ')' */
-
- while (*type != _C_UNION_E && *type++ != '=')
- ;
- while (*type != _C_UNION_E)
- {
- type = objc_skip_typespec (type);
- }
- return ++type;
-
- case _C_PTR:
- /* Just skip the following typespec */
-
- return objc_skip_typespec (++type);
-
- default:
- {
- _objc_abort ("unknown type %s\n", type);
- return 0;
- }
- }
-}
-
-inline
-const char *
-objc_skip_offset (const char *type)
-{
- /* The offset is prepended by a '+' if the argument is passed in
- registers. PS: The compiler stopped generating this '+' in
- version 3.4. */
- if (*type == '+')
- type++;
-
- /* Some people claim that on some platforms, where the stack grows
- backwards, the compiler generates negative offsets (??). Skip a
- '-' for such a negative offset. */
- if (*type == '-')
- type++;
-
- /* Skip the digits that represent the offset. */
- while (isdigit ((unsigned char) *type))
- type++;
-
- return type;
-}
-
-const char *
-objc_skip_argspec (const char *type)
-{
- type = objc_skip_typespec (type);
- type = objc_skip_offset (type);
- return type;
-}
-
-char *
-method_copyReturnType (struct objc_method *method)
-{
- if (method == NULL)
- return 0;
- else
- {
- char *returnValue;
- size_t returnValueSize;
-
- /* Determine returnValueSize. */
- {
- /* Find the end of the first argument. We want to return the
- first argument spec, plus 1 byte for the \0 at the end. */
- const char *type = method->method_types;
- if (*type == '\0')
- return NULL;
- type = objc_skip_argspec (type);
- returnValueSize = type - method->method_types + 1;
- }
-
- /* Copy the first argument into returnValue. */
- returnValue = malloc (sizeof (char) * returnValueSize);
- memcpy (returnValue, method->method_types, returnValueSize);
- returnValue[returnValueSize - 1] = '\0';
-
- return returnValue;
- }
-}
-
-char *
-method_copyArgumentType (struct objc_method * method, unsigned int argumentNumber)
-{
- if (method == NULL)
- return 0;
- else
- {
- char *returnValue;
- const char *returnValueStart;
- size_t returnValueSize;
-
- /* Determine returnValueStart and returnValueSize. */
- {
- const char *type = method->method_types;
-
- /* Skip the first argument (return type). */
- type = objc_skip_argspec (type);
-
- /* Now keep skipping arguments until we get to
- argumentNumber. */
- while (argumentNumber > 0)
- {
- /* We are supposed to skip an argument, but the string is
- finished. This means we were asked for a non-existing
- argument. */
- if (*type == '\0')
- return NULL;
-
- type = objc_skip_argspec (type);
- argumentNumber--;
- }
-
- /* If the argument does not exist, return NULL. */
- if (*type == '\0')
- return NULL;
-
- returnValueStart = type;
- type = objc_skip_argspec (type);
- returnValueSize = type - returnValueStart + 1;
- }
-
- /* Copy the argument into returnValue. */
- returnValue = malloc (sizeof (char) * returnValueSize);
- memcpy (returnValue, returnValueStart, returnValueSize);
- returnValue[returnValueSize - 1] = '\0';
-
- return returnValue;
- }
-}
-
-void method_getReturnType (struct objc_method * method, char *returnValue,
- size_t returnValueSize)
-{
- if (returnValue == NULL || returnValueSize == 0)
- return;
-
- /* Zero the string; we'll then write the argument type at the
- beginning of it, if needed. */
- memset (returnValue, 0, returnValueSize);
-
- if (method == NULL)
- return;
- else
- {
- size_t argumentTypeSize;
-
- /* Determine argumentTypeSize. */
- {
- /* Find the end of the first argument. We want to return the
- first argument spec. */
- const char *type = method->method_types;
- if (*type == '\0')
- return;
- type = objc_skip_argspec (type);
- argumentTypeSize = type - method->method_types;
- if (argumentTypeSize > returnValueSize)
- argumentTypeSize = returnValueSize;
- }
- /* Copy the argument at the beginning of the string. */
- memcpy (returnValue, method->method_types, argumentTypeSize);
- }
-}
-
-void method_getArgumentType (struct objc_method * method, unsigned int argumentNumber,
- char *returnValue, size_t returnValueSize)
-{
- if (returnValue == NULL || returnValueSize == 0)
- return;
-
- /* Zero the string; we'll then write the argument type at the
- beginning of it, if needed. */
- memset (returnValue, 0, returnValueSize);
-
- if (method == NULL)
- return;
- else
- {
- const char *returnValueStart;
- size_t argumentTypeSize;
-
- /* Determine returnValueStart and argumentTypeSize. */
- {
- const char *type = method->method_types;
-
- /* Skip the first argument (return type). */
- type = objc_skip_argspec (type);
-
- /* Now keep skipping arguments until we get to
- argumentNumber. */
- while (argumentNumber > 0)
- {
- /* We are supposed to skip an argument, but the string is
- finished. This means we were asked for a non-existing
- argument. */
- if (*type == '\0')
- return;
-
- type = objc_skip_argspec (type);
- argumentNumber--;
- }
-
- /* If the argument does not exist, it's game over. */
- if (*type == '\0')
- return;
-
- returnValueStart = type;
- type = objc_skip_argspec (type);
- argumentTypeSize = type - returnValueStart;
- if (argumentTypeSize > returnValueSize)
- argumentTypeSize = returnValueSize;
- }
- /* Copy the argument at the beginning of the string. */
- memcpy (returnValue, returnValueStart, argumentTypeSize);
- }
-}
-
-unsigned int
-method_getNumberOfArguments (struct objc_method *method)
-{
- if (method == NULL)
- return 0;
- else
- {
- unsigned int i = 0;
- const char *type = method->method_types;
- while (*type)
- {
- type = objc_skip_argspec (type);
- i += 1;
- }
-
- if (i == 0)
- {
- /* This could only happen if method_types is invalid; in
- that case, return 0. */
- return 0;
- }
- else
- {
- /* Remove the return type. */
- return (i - 1);
- }
- }
-}
-
-unsigned
-objc_get_type_qualifiers (const char *type)
-{
- unsigned res = 0;
- BOOL flag = YES;
-
- while (flag)
- switch (*type++)
- {
- case _C_CONST: res |= _F_CONST; break;
- case _C_IN: res |= _F_IN; break;
- case _C_INOUT: res |= _F_INOUT; break;
- case _C_OUT: res |= _F_OUT; break;
- case _C_BYCOPY: res |= _F_BYCOPY; break;
- case _C_BYREF: res |= _F_BYREF; break;
- case _C_ONEWAY: res |= _F_ONEWAY; break;
- case _C_GCINVISIBLE: res |= _F_GCINVISIBLE; break;
- default: flag = NO;
- }
-
- return res;
-}
-
-/* The following three functions can be used to determine how a
- structure is laid out by the compiler. For example:
-
- struct objc_struct_layout layout;
- int i;
-
- objc_layout_structure (type, &layout);
- while (objc_layout_structure_next_member (&layout))
- {
- int position, align;
- const char *type;
-
- objc_layout_structure_get_info (&layout, &position, &align, &type);
- printf ("element %d has offset %d, alignment %d\n",
- i++, position, align);
- }
-
- These functions are used by objc_sizeof_type and objc_alignof_type
- functions to compute the size and alignment of structures. The
- previous method of computing the size and alignment of a structure
- was not working on some architectures, particularly on AIX, and in
- the presence of bitfields inside the structure. */
-void
-objc_layout_structure (const char *type,
- struct objc_struct_layout *layout)
-{
- const char *ntype;
-
- if (*type != _C_UNION_B && *type != _C_STRUCT_B)
- {
- _objc_abort ("record (or union) type expected in objc_layout_structure, got %s\n",
- type);
- }
-
- type ++;
- layout->original_type = type;
-
- /* Skip "<name>=" if any. Avoid embedded structures and unions. */
- ntype = type;
- while (*ntype != _C_STRUCT_E && *ntype != _C_STRUCT_B && *ntype != _C_UNION_B
- && *ntype++ != '=')
- /* do nothing */;
-
- /* If there's a "<name>=", ntype - 1 points to '='; skip the the name */
- if (*(ntype - 1) == '=')
- type = ntype;
-
- layout->type = type;
- layout->prev_type = NULL;
- layout->record_size = 0;
- layout->record_align = __CHAR_BIT__;
-
- layout->record_align = MAX (layout->record_align, STRUCTURE_SIZE_BOUNDARY);
-}
-
-BOOL
-objc_layout_structure_next_member (struct objc_struct_layout *layout)
-{
- register int desired_align = 0;
-
- /* The following are used only if the field is a bitfield */
- register const char *bfld_type = 0;
- register int bfld_type_align = 0, bfld_field_size = 0;
-
- /* The current type without the type qualifiers */
- const char *type;
- BOOL unionp = layout->original_type[-1] == _C_UNION_B;
-
- /* Add the size of the previous field to the size of the record. */
- if (layout->prev_type)
- {
- type = objc_skip_type_qualifiers (layout->prev_type);
- if (unionp)
- layout->record_size = MAX (layout->record_size,
- objc_sizeof_type (type) * __CHAR_BIT__);
-
- else if (*type != _C_BFLD)
- layout->record_size += objc_sizeof_type (type) * __CHAR_BIT__;
- else {
- /* Get the bitfield's type */
- for (bfld_type = type + 1;
- isdigit ((unsigned char)*bfld_type);
- bfld_type++)
- /* do nothing */;
-
- bfld_type_align = objc_alignof_type (bfld_type) * __CHAR_BIT__;
- bfld_field_size = atoi (objc_skip_typespec (bfld_type));
- layout->record_size += bfld_field_size;
- }
- }
-
- if ((unionp && *layout->type == _C_UNION_E)
- || (!unionp && *layout->type == _C_STRUCT_E))
- return NO;
-
- /* Skip the variable name if any */
- layout->type = objc_skip_variable_name (layout->type);
- type = objc_skip_type_qualifiers (layout->type);
-
- if (*type != _C_BFLD)
- desired_align = objc_alignof_type (type) * __CHAR_BIT__;
- else
- {
- desired_align = 1;
- /* Skip the bitfield's offset */
- for (bfld_type = type + 1;
- isdigit ((unsigned char) *bfld_type);
- bfld_type++)
- /* do nothing */;
-
- bfld_type_align = objc_alignof_type (bfld_type) * __CHAR_BIT__;
- bfld_field_size = atoi (objc_skip_typespec (bfld_type));
- }
-
- /* The following won't work for vectors. */
-#ifdef BIGGEST_FIELD_ALIGNMENT
- desired_align = MIN (desired_align, BIGGEST_FIELD_ALIGNMENT);
-#endif
-#ifdef ADJUST_FIELD_ALIGN
- desired_align = ADJUST_FIELD_ALIGN (type, type, desired_align);
-#endif
-
- /* Record must have at least as much alignment as any field.
- Otherwise, the alignment of the field within the record
- is meaningless. */
-#ifndef HAVE_BITFIELD_TYPE_MATTERS
- layout->record_align = MAX (layout->record_align, desired_align);
-#else /* PCC_BITFIELD_TYPE_MATTERS */
- if (*type == _C_BFLD)
- {
- /* For these machines, a zero-length field does not
- affect the alignment of the structure as a whole.
- It does, however, affect the alignment of the next field
- within the structure. */
- if (bfld_field_size)
- layout->record_align = MAX (layout->record_align, desired_align);
- else
- desired_align = objc_alignof_type (bfld_type) * __CHAR_BIT__;
-
- /* A named bit field of declared type `int'
- forces the entire structure to have `int' alignment.
- Q1: How is encoded this thing and how to check for it?
- Q2: How to determine maximum_field_alignment at runtime? */
-
-/* if (DECL_NAME (field) != 0) */
- {
- int type_align = bfld_type_align;
-#if 0
- if (maximum_field_alignment != 0)
- type_align = MIN (type_align, maximum_field_alignment);
- else if (DECL_PACKED (field))
- type_align = MIN (type_align, __CHAR_BIT__);
-#endif
-
- layout->record_align = MAX (layout->record_align, type_align);
- }
- }
- else
- layout->record_align = MAX (layout->record_align, desired_align);
-#endif /* PCC_BITFIELD_TYPE_MATTERS */
-
- /* Does this field automatically have alignment it needs
- by virtue of the fields that precede it and the record's
- own alignment? */
-
- if (*type == _C_BFLD)
- layout->record_size = atoi (type + 1);
- else if (layout->record_size % desired_align != 0)
- {
- /* No, we need to skip space before this field.
- Bump the cumulative size to multiple of field alignment. */
- layout->record_size = ROUND (layout->record_size, desired_align);
- }
-
- /* Jump to the next field in record. */
-
- layout->prev_type = layout->type;
- layout->type = objc_skip_typespec (layout->type); /* skip component */
-
- return YES;
-}
-
-void objc_layout_finish_structure (struct objc_struct_layout *layout,
- unsigned int *size,
- unsigned int *align)
-{
- BOOL unionp = layout->original_type[-1] == _C_UNION_B;
- if (layout->type
- && ((!unionp && *layout->type == _C_STRUCT_E)
- || (unionp && *layout->type == _C_UNION_E)))
- {
- /* Work out the alignment of the record as one expression and store
- in the record type. Round it up to a multiple of the record's
- alignment. */
-#if defined (ROUND_TYPE_ALIGN) && ! defined (__sparc__)
- layout->record_align = ROUND_TYPE_ALIGN (layout->original_type-1,
- 1,
- layout->record_align);
-#else
- layout->record_align = MAX (1, layout->record_align);
-#endif
-
- /* Round the size up to be a multiple of the required alignment */
- layout->record_size = ROUND (layout->record_size, layout->record_align);
-
- layout->type = NULL;
- }
- if (size)
- *size = layout->record_size / __CHAR_BIT__;
- if (align)
- *align = layout->record_align / __CHAR_BIT__;
-}
-
-void objc_layout_structure_get_info (struct objc_struct_layout *layout,
- unsigned int *offset,
- unsigned int *align,
- const char **type)
-{
- if (offset)
- *offset = layout->record_size / __CHAR_BIT__;
- if (align)
- *align = layout->record_align / __CHAR_BIT__;
- if (type)
- *type = layout->prev_type;
-}
diff --git a/libgcobol/error.c b/libgcobol/error.c
deleted file mode 100644
index 188fcd3b0ef0..000000000000
--- a/libgcobol/error.c
+++ /dev/null
@@ -1,42 +0,0 @@
-/* GNU Objective C Runtime Error Functions
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-
-/* Prints an error message and aborts the program. */
-void
-_objc_abort (const char *fmt, ...)
-{
- va_list ap;
-
- va_start (ap, fmt);
- vfprintf (stderr, fmt, ap);
- abort ();
- va_end (ap);
-}
diff --git a/libgcobol/exception.c b/libgcobol/exception.c
deleted file mode 100644
index 24ea3bde1bca..000000000000
--- a/libgcobol/exception.c
+++ /dev/null
@@ -1,537 +0,0 @@
-/* The implementation of exception handling primitives for Objective-C.
- Copyright (C) 2004-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include <stdlib.h>
-#include "config.h"
-#include "objc/runtime.h"
-#include "objc/objc-exception.h"
-#include "unwind.h"
-#include "unwind-pe.h"
-#include <string.h> /* For memcpy */
-
-/* 'is_kind_of_exception_matcher' is our default exception matcher -
- it determines if the object 'exception' is of class 'catch_class',
- or of a subclass. */
-static int
-is_kind_of_exception_matcher (Class catch_class, id exception)
-{
- /* NULL catch_class is catch-all (eg, @catch (id object)). */
- if (catch_class == Nil)
- return 1;
-
- /* If exception is nil (eg, @throw nil;), then it can only be
- catched by a catch-all (eg, @catch (id object)). */
- if (exception != nil)
- {
- Class c;
-
- for (c = exception->class_pointer; c != Nil;
- c = class_getSuperclass (c))
- if (c == catch_class)
- return 1;
- }
- return 0;
-}
-
-/* The exception matcher currently in use. */
-static objc_exception_matcher
-__objc_exception_matcher = is_kind_of_exception_matcher;
-
-objc_exception_matcher
-objc_setExceptionMatcher (objc_exception_matcher new_matcher)
-{
- objc_exception_matcher old_matcher = __objc_exception_matcher;
- __objc_exception_matcher = new_matcher;
- return old_matcher;
-}
-
-/* The uncaught exception handler currently in use. */
-static objc_uncaught_exception_handler
-__objc_uncaught_exception_handler = NULL;
-
-objc_uncaught_exception_handler
-objc_setUncaughtExceptionHandler (objc_uncaught_exception_handler
- new_handler)
-{
- objc_uncaught_exception_handler old_handler
- = __objc_uncaught_exception_handler;
- __objc_uncaught_exception_handler = new_handler;
- return old_handler;
-}
-
-
-
-#ifdef __ARM_EABI_UNWINDER__
-
-const _Unwind_Exception_Class __objc_exception_class
- = {'G', 'N', 'U', 'C', 'O', 'B', 'J', 'C'};
-
-#else
-
-/* This is the exception class we report -- "GNUCOBJC". */
-static const _Unwind_Exception_Class __objc_exception_class
- = ((((((((_Unwind_Exception_Class) 'G'
- << 8 | (_Unwind_Exception_Class) 'N')
- << 8 | (_Unwind_Exception_Class) 'U')
- << 8 | (_Unwind_Exception_Class) 'C')
- << 8 | (_Unwind_Exception_Class) 'O')
- << 8 | (_Unwind_Exception_Class) 'B')
- << 8 | (_Unwind_Exception_Class) 'J')
- << 8 | (_Unwind_Exception_Class) 'C');
-
-#endif
-
-/* This is the object that is passed around by the Objective C runtime
- to represent the exception in flight. */
-struct ObjcException
-{
- /* This bit is needed in order to interact with the unwind runtime. */
- struct _Unwind_Exception base;
-
- /* The actual object we want to throw. Note: must come immediately
- after unwind header. */
- id value;
-
-#ifdef __ARM_EABI_UNWINDER__
- /* Note: we use the barrier cache defined in the unwind control
- block for ARM EABI. */
-#else
- /* Cache some internal unwind data between phase 1 and phase 2. */
- _Unwind_Ptr landingPad;
- int handlerSwitchValue;
-#endif
-};
-
-
-
-struct lsda_header_info
-{
- _Unwind_Ptr Start;
- _Unwind_Ptr LPStart;
- _Unwind_Ptr ttype_base;
- const unsigned char *TType;
- const unsigned char *action_table;
- unsigned char ttype_encoding;
- unsigned char call_site_encoding;
-};
-
-static const unsigned char *
-parse_lsda_header (struct _Unwind_Context *context, const unsigned char *p,
- struct lsda_header_info *info)
-{
- _uleb128_t tmp;
- unsigned char lpstart_encoding;
-
- info->Start = (context ? _Unwind_GetRegionStart (context) : 0);
-
- /* Find @LPStart, the base to which landing pad offsets are
- relative. */
- lpstart_encoding = *p++;
- if (lpstart_encoding != DW_EH_PE_omit)
- p = read_encoded_value (context, lpstart_encoding, p, &info->LPStart);
- else
- info->LPStart = info->Start;
-
- /* Find @TType, the base of the handler and exception spec type
- data. */
- info->ttype_encoding = *p++;
- if (info->ttype_encoding != DW_EH_PE_omit)
- {
-#if _GLIBCXX_OVERRIDE_TTYPE_ENCODING
- /* Older ARM EABI toolchains set this value incorrectly, so use a
- hardcoded OS-specific format. */
- info->ttype_encoding = _GLIBCXX_OVERRIDE_TTYPE_ENCODING;
-#endif
- p = read_uleb128 (p, &tmp);
- info->TType = p + tmp;
- }
- else
- info->TType = 0;
-
- /* The encoding and length of the call-site table; the action table
- immediately follows. */
- info->call_site_encoding = *p++;
- p = read_uleb128 (p, &tmp);
- info->action_table = p + tmp;
-
- return p;
-}
-
-static Class
-get_ttype_entry (struct lsda_header_info *info, _Unwind_Word i)
-{
- _Unwind_Ptr ptr;
-
- i *= size_of_encoded_value (info->ttype_encoding);
- read_encoded_value_with_base (info->ttype_encoding, info->ttype_base,
- info->TType - i, &ptr);
-
- /* NULL ptr means catch-all. Note that if the class is not found,
- this will abort the program. */
- if (ptr)
- return objc_getRequiredClass ((const char *) ptr);
- else
- return 0;
-}
-
-/* Using a different personality function name causes link failures
- when trying to mix code using different exception handling
- models. */
-#ifdef __USING_SJLJ_EXCEPTIONS__
-#define PERSONALITY_FUNCTION __gnu_objc_personality_sj0
-#define __builtin_eh_return_data_regno(x) x
-#elif defined(__SEH__)
-#define PERSONALITY_FUNCTION __gnu_objc_personality_imp
-#else
-#define PERSONALITY_FUNCTION __gnu_objc_personality_v0
-#endif
-
-#ifdef __ARM_EABI_UNWINDER__
-
-#define CONTINUE_UNWINDING \
- do \
- { \
- if (__gnu_unwind_frame(ue_header, context) != _URC_OK) \
- return _URC_FAILURE; \
- return _URC_CONTINUE_UNWIND; \
- } \
- while (0)
-
-_Unwind_Reason_Code
-__attribute__((target ("general-regs-only")))
-PERSONALITY_FUNCTION (_Unwind_State state,
- struct _Unwind_Exception *ue_header,
- struct _Unwind_Context *context)
-#else
-
-#define CONTINUE_UNWINDING return _URC_CONTINUE_UNWIND
-
-#if defined (__SEH__) && !defined (__USING_SJLJ_EXCEPTIONS__)
-static
-#endif
-_Unwind_Reason_Code
-PERSONALITY_FUNCTION (int version,
- _Unwind_Action actions,
- _Unwind_Exception_Class exception_class,
- struct _Unwind_Exception *ue_header,
- struct _Unwind_Context *context)
-#endif
-{
- struct ObjcException *xh = (struct ObjcException *) ue_header;
-
- struct lsda_header_info info;
- const unsigned char *language_specific_data;
- const unsigned char *action_record;
- const unsigned char *p;
- _Unwind_Ptr landing_pad, ip;
- int handler_switch_value;
- int saw_cleanup = 0, saw_handler, foreign_exception;
- void *return_object;
- int ip_before_insn = 0;
-
-#ifdef __ARM_EABI_UNWINDER__
- _Unwind_Action actions;
-
- switch (state & _US_ACTION_MASK)
- {
- case _US_VIRTUAL_UNWIND_FRAME:
- actions = _UA_SEARCH_PHASE;
- break;
-
- case _US_UNWIND_FRAME_STARTING:
- actions = _UA_CLEANUP_PHASE;
- if (!(state & _US_FORCE_UNWIND)
- && ue_header->barrier_cache.sp == _Unwind_GetGR (context, 13))
- actions |= _UA_HANDLER_FRAME;
- break;
-
- case _US_UNWIND_FRAME_RESUME:
- CONTINUE_UNWINDING;
- break;
-
- default:
- abort();
- }
- actions |= state & _US_FORCE_UNWIND;
-
- /* TODO: Foreign exceptions need some attention (e.g. rethrowing
- doesn't work). */
- foreign_exception = 0;
-
- /* The dwarf unwinder assumes the context structure holds things
- like the function and LSDA pointers. The ARM implementation
- caches these in the exception header (UCB). To avoid rewriting
- everything we make the virtual IP register point at the UCB. */
- ip = (_Unwind_Ptr) ue_header;
- _Unwind_SetGR (context, 12, ip);
-
-#else /* !__ARM_EABI_UNWINDER. */
- /* Interface version check. */
- if (version != 1)
- return _URC_FATAL_PHASE1_ERROR;
-
- foreign_exception = (exception_class != __objc_exception_class);
-#endif
-
- /* Shortcut for phase 2 found handler for domestic exception. */
- if (actions == (_UA_CLEANUP_PHASE | _UA_HANDLER_FRAME)
- && !foreign_exception)
- {
-#ifdef __ARM_EABI_UNWINDER__
- handler_switch_value = (int) ue_header->barrier_cache.bitpattern[1];
- landing_pad = (_Unwind_Ptr) ue_header->barrier_cache.bitpattern[3];
-#else
- handler_switch_value = xh->handlerSwitchValue;
- landing_pad = xh->landingPad;
-#endif
- goto install_context;
- }
-
- language_specific_data = (const unsigned char *)
- _Unwind_GetLanguageSpecificData (context);
-
- /* If no LSDA, then there are no handlers or cleanups. */
- if (! language_specific_data)
- CONTINUE_UNWINDING;
-
- /* Parse the LSDA header. */
- p = parse_lsda_header (context, language_specific_data, &info);
- info.ttype_base = base_of_encoded_value (info.ttype_encoding, context);
-#ifdef HAVE_GETIPINFO
- ip = _Unwind_GetIPInfo (context, &ip_before_insn);
-#else
- ip = _Unwind_GetIP (context);
-#endif
- if (!ip_before_insn)
- --ip;
- landing_pad = 0;
- action_record = 0;
- handler_switch_value = 0;
-
-#ifdef __USING_SJLJ_EXCEPTIONS__
- /* The given "IP" is an index into the call-site table, with two
- exceptions -- -1 means no-action, and 0 means terminate. But
- since we're using uleb128 values, we've not got random access to
- the array. */
- if ((int) ip < 0)
- return _URC_CONTINUE_UNWIND;
- else
- {
- _uleb128_t cs_lp, cs_action;
- do
- {
- p = read_uleb128 (p, &cs_lp);
- p = read_uleb128 (p, &cs_action);
- }
- while (--ip);
-
- /* Can never have null landing pad for sjlj -- that would have
- been indicated by a -1 call site index. */
- landing_pad = cs_lp + 1;
- if (cs_action)
- action_record = info.action_table + cs_action - 1;
- goto found_something;
- }
-#else
- /* Search the call-site table for the action associated with this
- IP. */
- while (p < info.action_table)
- {
- _Unwind_Ptr cs_start, cs_len, cs_lp;
- _uleb128_t cs_action;
-
- /* Note that all call-site encodings are "absolute"
- displacements. */
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_start);
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_len);
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_lp);
- p = read_uleb128 (p, &cs_action);
-
- /* The table is sorted, so if we've passed the ip, stop. */
- if (ip < info.Start + cs_start)
- p = info.action_table;
- else if (ip < info.Start + cs_start + cs_len)
- {
- if (cs_lp)
- landing_pad = info.LPStart + cs_lp;
- if (cs_action)
- action_record = info.action_table + cs_action - 1;
- goto found_something;
- }
- }
-#endif /* __USING_SJLJ_EXCEPTIONS__ */
-
- /* If ip is not present in the table, C++ would call terminate. */
- /* ??? As with Java, it's perhaps better to tweek the LSDA to that
- no-action is mapped to no-entry. */
- CONTINUE_UNWINDING;
-
- found_something:
- saw_cleanup = 0;
- saw_handler = 0;
-
- if (landing_pad == 0)
- {
- /* If ip is present, and has a null landing pad, there are no
- cleanups or handlers to be run. */
- }
- else if (action_record == 0)
- {
- /* If ip is present, has a non-null landing pad, and a null
- action table offset, then there are only cleanups present.
- Cleanups use a zero switch value, as set above. */
- saw_cleanup = 1;
- }
- else
- {
- /* Otherwise we have a catch handler. */
- _sleb128_t ar_filter, ar_disp;
-
- while (1)
- {
- p = action_record;
- p = read_sleb128 (p, &ar_filter);
- read_sleb128 (p, &ar_disp);
-
- if (ar_filter == 0)
- {
- /* Zero filter values are cleanups. */
- saw_cleanup = 1;
- }
-
- /* During forced unwinding, we only run cleanups. With a
- foreign exception class, we have no class info to
- match. */
- else if ((actions & _UA_FORCE_UNWIND) || foreign_exception)
- ;
-
- else if (ar_filter > 0)
- {
- /* Positive filter values are handlers. */
- Class catch_type = get_ttype_entry (&info, ar_filter);
-
- if ((*__objc_exception_matcher) (catch_type, xh->value))
- {
- handler_switch_value = ar_filter;
- saw_handler = 1;
- break;
- }
- }
- else
- {
- /* Negative filter values are exception specifications,
- which Objective-C does not use. */
- abort ();
- }
-
- if (ar_disp == 0)
- break;
- action_record = p + ar_disp;
- }
- }
-
- if (! saw_handler && ! saw_cleanup)
- CONTINUE_UNWINDING;
-
- if (actions & _UA_SEARCH_PHASE)
- {
- if (!saw_handler)
- CONTINUE_UNWINDING;
-
- /* For domestic exceptions, we cache data from phase 1 for phase
- 2. */
- if (!foreign_exception)
- {
-#ifdef __ARM_EABI_UNWINDER__
- ue_header->barrier_cache.sp = _Unwind_GetGR (context, 13);
- ue_header->barrier_cache.bitpattern[1] = (_uw) handler_switch_value;
- ue_header->barrier_cache.bitpattern[3] = (_uw) landing_pad;
-#else
- xh->handlerSwitchValue = handler_switch_value;
- xh->landingPad = landing_pad;
-#endif
- }
- return _URC_HANDLER_FOUND;
- }
-
- install_context:
- if (saw_cleanup == 0)
- {
- return_object = xh->value;
- if (!(actions & _UA_SEARCH_PHASE))
- _Unwind_DeleteException(&xh->base);
- }
-
- _Unwind_SetGR (context, __builtin_eh_return_data_regno (0),
- __builtin_extend_pointer (saw_cleanup ? xh : return_object));
- _Unwind_SetGR (context, __builtin_eh_return_data_regno (1),
- handler_switch_value);
- _Unwind_SetIP (context, landing_pad);
- return _URC_INSTALL_CONTEXT;
-}
-
-static void
-__objc_exception_cleanup (_Unwind_Reason_Code code __attribute__((unused)),
- struct _Unwind_Exception *exc)
-{
- free (exc);
-}
-
-void
-objc_exception_throw (id exception)
-{
- struct ObjcException *header = calloc (1, sizeof (*header));
-
- memcpy (&header->base.exception_class, &__objc_exception_class,
- sizeof (__objc_exception_class));
- header->base.exception_cleanup = __objc_exception_cleanup;
- header->value = exception;
-
-#ifdef __USING_SJLJ_EXCEPTIONS__
- _Unwind_SjLj_RaiseException (&header->base);
-#else
- _Unwind_RaiseException (&header->base);
-#endif
-
- /* No exception handler was installed. Call the uncaught exception
- handler if any is defined. */
- if (__objc_uncaught_exception_handler != 0)
- {
- (*__objc_uncaught_exception_handler) (exception);
- }
-
- abort ();
-}
-
-#if defined (__SEH__) && !defined (__USING_SJLJ_EXCEPTIONS__)
-EXCEPTION_DISPOSITION
-__gnu_objc_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
- PCONTEXT ms_orig_context,
- PDISPATCHER_CONTEXT ms_disp)
-{
- return _GCC_specific_handler (ms_exc, this_frame, ms_orig_context,
- ms_disp, __gnu_objc_personality_imp);
-}
-#endif
diff --git a/libgcobol/gc.c b/libgcobol/gc.c
deleted file mode 100644
index af3eafbd185d..000000000000
--- a/libgcobol/gc.c
+++ /dev/null
@@ -1,459 +0,0 @@
-/* Basic data types for Objective C.
- Copyright (C) 1998-2022 Free Software Foundation, Inc.
- Contributed by Ovidiu Predescu.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/objc.h"
-
-#if OBJC_WITH_GC
-
-#include "tconfig.h"
-#include <assert.h>
-#include <ctype.h> /* For isdigit. */
-#include <string.h>
-#include <stdlib.h>
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h"
-
-#include <gc/gc.h>
-#include <limits.h>
-
-/* gc_typed.h uses the following but doesn't declare them */
-typedef GC_word word;
-typedef GC_signed_word signed_word;
-#define BITS_PER_WORD (CHAR_BIT * sizeof (word))
-
-#include <gc/gc_typed.h>
-
-/* The following functions set up in `mask` the corresponding pointers.
- The offset is incremented with the size of the type. */
-
-#define ROUND(V, A) \
- ({ typeof (V) __v = (V); typeof (A) __a = (A); \
- __a * ((__v+__a - 1)/__a); })
-
-#define SET_BIT_FOR_OFFSET(mask, offset) \
- GC_set_bit (mask, offset / sizeof (void *))
-
-/* Some prototypes */
-static void
-__objc_gc_setup_struct (GC_bitmap mask, const char *type, int offset);
-static void
-__objc_gc_setup_union (GC_bitmap mask, const char *type, int offset);
-
-
-static void
-__objc_gc_setup_array (GC_bitmap mask, const char *type, int offset)
-{
- int i, len = atoi (type + 1);
-
- while (isdigit (*++type))
- /* do nothing */; /* skip the size of the array */
-
- switch (*type) {
- case _C_ARY_B:
- for (i = 0; i < len; i++)
- __objc_gc_setup_array (mask, type, offset);
- break;
-
- case _C_STRUCT_B:
- for (i = 0; i < len; i++)
- __objc_gc_setup_struct (mask, type, offset);
- break;
-
- case _C_UNION_B:
- for (i = 0; i < len; i++)
- __objc_gc_setup_union (mask, type, offset);
- break;
-
- default:
- break;
- }
-}
-
-static void
-__objc_gc_setup_struct (GC_bitmap mask, const char *type, int offset)
-{
- struct objc_struct_layout layout;
- unsigned int position;
- const char *mtype;
-
- objc_layout_structure (type, &layout);
-
- while (objc_layout_structure_next_member (&layout))
- {
- BOOL gc_invisible = NO;
-
- objc_layout_structure_get_info (&layout, &position, NULL, &mtype);
-
- /* Skip the variable name */
- if (*mtype == '"')
- {
- for (mtype++; *mtype++ != '"';)
- /* do nothing */;
- }
-
- if (*mtype == _C_GCINVISIBLE)
- {
- gc_invisible = YES;
- mtype++;
- }
-
- /* Add to position the offset of this structure */
- position += offset;
-
- switch (*mtype) {
- case _C_ID:
- case _C_CLASS:
- case _C_SEL:
- case _C_PTR:
- case _C_CHARPTR:
- case _C_ATOM:
- if (! gc_invisible)
- SET_BIT_FOR_OFFSET (mask, position);
- break;
-
- case _C_ARY_B:
- __objc_gc_setup_array (mask, mtype, position);
- break;
-
- case _C_STRUCT_B:
- __objc_gc_setup_struct (mask, mtype, position);
- break;
-
- case _C_UNION_B:
- __objc_gc_setup_union (mask, mtype, position);
- break;
-
- default:
- break;
- }
- }
-}
-
-static void
-__objc_gc_setup_union (GC_bitmap mask, const char *type, int offset)
-{
- /* Sub-optimal, quick implementation: assume the union is made of
- pointers, set up the mask accordingly. */
-
- int i, size, align;
-
- /* Skip the variable name */
- if (*type == '"')
- {
- for (type++; *type++ != '"';)
- /* do nothing */;
- }
-
- size = objc_sizeof_type (type);
- align = objc_alignof_type (type);
-
- offset = ROUND (offset, align);
- for (i = 0; i < size; i += sizeof (void *))
- {
- SET_BIT_FOR_OFFSET (mask, offset);
- offset += sizeof (void *);
- }
-}
-
-
-/* Iterates over the types in the structure that represents the class
- encoding and sets the bits in mask according to each ivar type. */
-static void
-__objc_gc_type_description_from_type (GC_bitmap mask, const char *type)
-{
- struct objc_struct_layout layout;
- unsigned int offset, align;
- const char *ivar_type;
-
- objc_layout_structure (type, &layout);
-
- while (objc_layout_structure_next_member (&layout))
- {
- BOOL gc_invisible = NO;
-
- objc_layout_structure_get_info (&layout, &offset, &align, &ivar_type);
-
- /* Skip the variable name */
- if (*ivar_type == '"')
- {
- for (ivar_type++; *ivar_type++ != '"';)
- /* do nothing */;
- }
-
- if (*ivar_type == _C_GCINVISIBLE)
- {
- gc_invisible = YES;
- ivar_type++;
- }
-
- switch (*ivar_type) {
- case _C_ID:
- case _C_CLASS:
- case _C_SEL:
- case _C_PTR:
- case _C_CHARPTR:
- if (! gc_invisible)
- SET_BIT_FOR_OFFSET (mask, offset);
- break;
-
- case _C_ARY_B:
- __objc_gc_setup_array (mask, ivar_type, offset);
- break;
-
- case _C_STRUCT_B:
- __objc_gc_setup_struct (mask, ivar_type, offset);
- break;
-
- case _C_UNION_B:
- __objc_gc_setup_union (mask, ivar_type, offset);
- break;
-
- default:
- break;
- }
- }
-}
-
-/* Computes in *type the full type encoding of this class including
- its super classes. '*size' gives the total number of bytes allocated
- into *type, '*current' the number of bytes used so far by the
- encoding. */
-static void
-__objc_class_structure_encoding (Class class, char **type, int *size,
- int *current)
-{
- int i, ivar_count;
- struct objc_ivar_list *ivars;
-
- if (! class)
- {
- strcat (*type, "{");
- (*current)++;
- return;
- }
-
- /* Add the type encodings of the super classes */
- __objc_class_structure_encoding (class->super_class, type, size, current);
-
- ivars = class->ivars;
- if (! ivars)
- return;
-
- ivar_count = ivars->ivar_count;
-
- for (i = 0; i < ivar_count; i++)
- {
- struct objc_ivar *ivar = &(ivars->ivar_list[i]);
- const char *ivar_type = ivar->ivar_type;
- int len = strlen (ivar_type);
-
- if (*current + len + 1 >= *size)
- {
- /* Increase the size of the encoding string so that it
- contains this ivar's type. */
- *size = ROUND (*current + len + 1, 10);
- *type = objc_realloc (*type, *size);
- }
- strcat (*type + *current, ivar_type);
- *current += len;
- }
-}
-
-
-/* Allocates the memory that will hold the type description for class
- and calls the __objc_class_structure_encoding that generates this
- value. */
-void
-__objc_generate_gc_type_description (Class class)
-{
- GC_bitmap mask;
- int bits_no, size;
- int type_size = 10, current;
- char *class_structure_type;
-
- if (! CLS_ISCLASS (class))
- return;
-
- /* We have to create a mask in which each bit counts for a pointer member.
- We take into consideration all the non-pointer instance variables and we
- round them up to the alignment. */
-
- /* The number of bits in the mask is the size of an instance in bytes divided
- by the size of a pointer. */
- bits_no = (ROUND (class_getInstanceSize (class), sizeof (void *))
- / sizeof (void *));
- size = ROUND (bits_no, BITS_PER_WORD) / BITS_PER_WORD;
- mask = objc_atomic_malloc (size * sizeof (int));
- memset (mask, 0, size * sizeof (int));
-
- class_structure_type = objc_atomic_malloc (type_size);
- *class_structure_type = current = 0;
- __objc_class_structure_encoding (class, &class_structure_type,
- &type_size, ¤t);
- if (current + 1 == type_size)
- class_structure_type = objc_realloc (class_structure_type, ++type_size);
- strcat (class_structure_type + current, "}");
-#ifdef DEBUG
- printf ("type description for '%s' is %s\n", class->name, class_structure_type);
-#endif
-
- __objc_gc_type_description_from_type (mask, class_structure_type);
- objc_free (class_structure_type);
-
-#ifdef DEBUG
- printf (" mask for '%s', type '%s' (bits %d, mask size %d) is:",
- class_structure_type, class->name, bits_no, size);
- {
- int i;
- for (i = 0; i < size; i++)
- printf (" %lx", mask[i]);
- }
- puts ("");
-#endif
-
- class->gc_object_type = (void *) GC_make_descriptor (mask, bits_no);
-}
-
-
-/* Returns YES if type denotes a pointer type, NO otherwise */
-static inline BOOL
-__objc_ivar_pointer (const char *type)
-{
- type = objc_skip_type_qualifiers (type);
-
- return (*type == _C_ID
- || *type == _C_CLASS
- || *type == _C_SEL
- || *type == _C_PTR
- || *type == _C_CHARPTR
- || *type == _C_ATOM);
-}
-
-
-/* Mark the instance variable whose name is given by ivarname as a
- weak pointer (a pointer hidden to the garbage collector) if
- gc_invisible is true. If gc_invisible is false it unmarks the
- instance variable and makes it a normal pointer, visible to the
- garbage collector.
-
- This operation only makes sense on instance variables that are
- pointers. */
-void
-class_ivar_set_gcinvisible (Class class, const char *ivarname,
- BOOL gc_invisible)
-{
- int i, ivar_count;
- struct objc_ivar_list *ivars;
-
- if (! class || ! ivarname)
- return;
-
- ivars = class->ivars;
- if (! ivars)
- return;
-
- ivar_count = ivars->ivar_count;
-
- for (i = 0; i < ivar_count; i++)
- {
- struct objc_ivar *ivar = &(ivars->ivar_list[i]);
- const char *type;
-
- if (! ivar->ivar_name || strcmp (ivar->ivar_name, ivarname))
- continue;
-
- assert (ivar->ivar_type);
- type = ivar->ivar_type;
-
- /* Skip the variable name */
- if (*type == '"')
- {
- for (type++; *type++ != '"';)
- /* do nothing */;
- }
-
- if (*type == _C_GCINVISIBLE)
- {
- char *new_type;
- size_t len;
-
- if (gc_invisible || ! __objc_ivar_pointer (type))
- return; /* The type of the variable already matches the
- requested gc_invisible type */
-
- /* The variable is gc_invisible so we make it gc visible. */
- new_type = objc_atomic_malloc (strlen(ivar->ivar_type));
- len = (type - ivar->ivar_type);
- memcpy (new_type, ivar->ivar_type, len);
- new_type[len] = 0;
- strcat (new_type, type + 1);
- ivar->ivar_type = new_type;
- }
- else
- {
- char *new_type;
- size_t len;
-
- if (! gc_invisible || ! __objc_ivar_pointer (type))
- return; /* The type of the variable already matches the
- requested gc_invisible type */
-
- /* The variable is gc visible so we make it gc_invisible. */
- new_type = objc_malloc (strlen(ivar->ivar_type) + 2);
-
- /* Copy the variable name. */
- len = (type - ivar->ivar_type);
- memcpy (new_type, ivar->ivar_type, len);
- /* Add '!'. */
- new_type[len++] = _C_GCINVISIBLE;
- /* Copy the original types. */
- strcpy (new_type + len, type);
-
- ivar->ivar_type = new_type;
- }
-
- __objc_generate_gc_type_description (class);
- return;
- }
-
- /* Search the instance variable in the superclasses */
- class_ivar_set_gcinvisible (class->super_class, ivarname, gc_invisible);
-}
-
-#else /* !OBJC_WITH_GC */
-
-void
-__objc_generate_gc_type_description (Class class __attribute__ ((__unused__)))
-{
-}
-
-void class_ivar_set_gcinvisible (Class class __attribute__ ((__unused__)),
- const char *ivarname __attribute__ ((__unused__)),
- BOOL gc_invisible __attribute__ ((__unused__)))
-{
-}
-
-#endif /* OBJC_WITH_GC */
diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc
new file mode 100644
index 000000000000..3c89a6157bec
--- /dev/null
+++ b/libgcobol/gfileio.cc
@@ -0,0 +1,2427 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (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 <algorithm>
+
+#include "libgcobol.h"
+#include "gfileio.h"
+#include "charmaps.h"
+
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+
+#pragma GCC diagnostic ignored "-Wunused-result"
+
+extern "C"
+void
+__gg__handle_error(const char *function, const char *msg)
+ {
+ if(1)
+ {
+ fflush(stdout);
+ char ach[1024];
+ snprintf(ach, sizeof(ach), "%s(): %s", function, msg);
+ perror(ach);
+ }
+
+ errno = 0;
+ }
+
+static bool
+handle_feof(cblc_file_t *file)
+ {
+ bool retval = false;
+ if( feof(file->file_pointer) )
+ {
+ // This is an end-of-file, which isn't really an error.
+ retval = true;
+ file->io_status = FsEofSeq; // "10"
+ }
+ return retval;
+ }
+
+static bool
+handle_ferror(cblc_file_t *file, const char *function, const char *msg)
+ {
+ // This routine gets called after an I/O operation that might fail
+ bool retval = false; // Indicates no error
+ file->errnum = errno;
+ if( ferror(file->file_pointer) )
+ {
+ // There was some kind of actionable error:
+ retval = true;
+ // Optionally tell the world of our troubles:
+ if(1)
+ {
+ fflush(stdout);
+ char ach[1024];
+ snprintf(ach, sizeof(ach), "%s(): %s", function, msg);
+ perror(ach);
+ }
+
+ // Set up for the next I/O operation
+ clearerr(file->file_pointer);
+ errno = 0;
+ }
+ return retval;
+ }
+
+static
+char *get_filename( cblc_file_t *file,
+ int is_quoted)
+ {
+ char *fname = internal_to_console(file->filename, strlen(file->filename));
+
+ char *trimmed_name = NULL;
+ if( is_quoted )
+ {
+ // We have been fed the literal, no-questions-asked, file name
+ trimmed_name = strdup(fname);
+ }
+ else
+ {
+ // We have been given something that might be the name of an
+ // environment variable that contains the filename:
+ char *p_from_environment = getenv(fname);
+ if( p_from_environment )
+ {
+ trimmed_name = strdup(p_from_environment);
+ }
+ }
+
+ if(trimmed_name)
+ {
+ // COBOL strings are space-filled to the right, so we have to get rid
+ // of any spaces out there. If somebody *wants* a filename space-filled
+ // to the right, well, at this juncture I am not prepared to be complicit
+ // in that particular flavor of lunacy.
+ size_t n = strlen(trimmed_name)-1;
+ // Note the conditional that terminates the loop when n goes from zero
+ // to a huge positive number in the event that the string is all SPACES
+ while( n < strlen(trimmed_name) && trimmed_name[n] == ascii_space )
+ {
+ trimmed_name[n--] = '\0';
+ }
+ }
+ free(fname);
+ return trimmed_name;
+ }
+
+static void
+establish_status(cblc_file_t *file, long read_location)
+ {
+ // Establish file->io_status with either FsErrno or a specific value
+ // before calling this routine:
+ // The complete integer goes to the compiler's internal status, which is
+ // a field that must exist.
+
+ file->errnum = errno;
+ file->prior_read_location = read_location;
+ file->io_status = __gg__file_status_word((file_status_t)file->io_status);
+
+ __gg__scale_and_assign_to_field(file->status,
+ file->io_status,
+ 0,
+ unrounded_e,
+ NULL);
+ if( file->user_status )
+ {
+ // This one might exist; if so, set it as well.
+ __gg__scale_and_assign_to_field(file->user_status,
+ file->io_status,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ }
+
+extern "C"
+void
+__gg__file_init(
+ cblc_file_t *file,
+ const char *name,
+ cblc_field_t **keys,
+ int *uniques,
+ cblc_field_t *password,
+ cblc_field_t *user_status,
+ cblc_field_t *vsam_status,
+ cblc_field_t *record_length,
+ cblc_field_t *status,
+ size_t reserve,
+ int org,
+ int padding,
+ int access,
+ int optional,
+ size_t record_area_size)
+ {
+ file->name = strdup(name);
+ file->filename = NULL ;
+ file->file_pointer = NULL ;
+ file->keys = keys;
+ file->uniques = uniques;
+ file->password = password ;
+ file->user_status = user_status ;
+ file->vsam_status = vsam_status ;
+ file->record_length = record_length ;
+ file->status = status ;
+ file->reserve = reserve ;
+ file->org = (cbl_file_org_t)org ;
+ file->padding = padding ;
+ file->access = (cbl_file_access_t)access ;
+ file->errnum = 0 ;
+ file->io_status = 0 ;
+ file->delimiter = internal_newline ;
+ file->flags = 0;
+ file->flags |= optional ? file_flag_optional_e : 0;
+ file->record_area_size = record_area_size;
+ }
+
+enum relative_file_mode
+ {
+ // MicroFocus uses a zero-byte prefix, and a two-byte postfix. The
+ // final byte is 0x0A for a valid record.
+ rfm_microfocus_e,
+ };
+
+enum indexed_file_mode
+ {
+ // Data file is the same as rfm_microfocus. We use maps and multimaps for
+ // the keys, in an extravaganza of expedience.
+ ifm_dubner_e,
+ };
+
+struct relative_file_parameters
+ {
+ long preamble_size;
+ long payload_size;
+ long postamble_size;
+ long file_size;
+ long key_value;
+ long record_position;
+ long flag_position;
+ long current_file_position;
+ int fd;
+ bool inside_existing_file;
+ };
+
+#define IGNORE_LIMITS false
+#define RESPECT_LIMITS true
+#define DONT_INIT_KEY false
+#define INIT_KEY true
+
+static bool
+relative_file_parameters_get( struct relative_file_parameters &rfp , // OUTPUT
+ relative_file_mode rfm, // INPUTS
+ cblc_file_t *file,
+ size_t length,
+ bool respect_limits,
+ bool initialize_key)
+ {
+ bool retval = false; // False means "okay"
+ errno = 0;
+ file->io_status = FsErrno;
+ switch(rfm)
+ {
+ case rfm_microfocus_e:
+ {
+ // Set MicroFocus-specific sizes:
+ rfp.preamble_size = 0;
+ rfp.payload_size = (long)length;
+ rfp.postamble_size = 2;
+ long record_size = rfp.preamble_size + rfp.payload_size + rfp.postamble_size;
+
+ // We need to know the current file size:
+ rfp.fd = fileno(file->file_pointer);
+ if( rfp.fd == -1 )
+ {
+ handle_ferror(file, __func__, "fileno() error" );
+ retval = true;
+ goto done;
+ }
+
+ struct stat file_status;
+ if( fstat(rfp.fd, &file_status) == -1 )
+ {
+ handle_ferror(file, __func__, "fstat() error");
+ retval = true;
+ goto done;
+ }
+ rfp.file_size = file_status.st_size;
+
+ rfp.current_file_position = ftell(file->file_pointer);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ retval = true;
+ goto done;
+ }
+
+ // Pick up the relative_key value:
+ if( initialize_key )
+ {
+ rfp.key_value = rfp.current_file_position/record_size + 1;
+ }
+ else
+ {
+ int hyphen;
+ int rdigits;
+ if( !file->keys[0] )
+ {
+ warnx("%s(): %s file->keys[0] is NULL, and it shouldn't be\n", __func__, file->name);
+ assert(file->keys[0]);
+ }
+ rfp.key_value = (long)__gg__binary_value_from_field(&hyphen, &rdigits, file->keys[0]);
+ }
+
+ rfp.record_position = (rfp.key_value-1) * record_size;
+ if( rfp.record_position < 0 )
+ {
+ // The record can't be found before the beginning of the file
+ file->io_status = FsNotFound; // "23"
+ retval = true;
+ goto done;
+ }
+
+ rfp.inside_existing_file = rfp.record_position + record_size <= rfp.file_size;
+
+ if( respect_limits && !rfp.inside_existing_file && file->mode_char == 'r')
+ {
+ // This is a READ operation, but the targeted location is not inside the file
+ file->io_status = FsNotFound; // "23"
+ retval = true;
+ goto done;
+ }
+
+ // For Microfocus, the flag is the final byte of the record:
+ rfp.flag_position = rfp.record_position + record_size - 1;
+
+ break;
+ }
+
+ default:
+ warnx("%s(): Unhandled relative_file_mode %d", __func__, rfm);
+ exit(1);
+ break;
+ }
+ done:
+ if( retval )
+ {
+ establish_status(file, -1);
+ }
+ return retval;
+ }
+
+static void
+file_relative_delete( cblc_file_t *file,
+ size_t length )
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ char record_marker;
+
+ if( !file->file_pointer )
+ {
+ // Attempting to delete in a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoDelete; // "49"
+ goto done;
+ }
+
+ if( file->mode_char != '+' )
+ {
+ // We have to be in I-O mode
+ errno = EBADF;
+ file->io_status = FsNoDelete; // "49"
+ goto done;
+ }
+
+ relative_file_parameters rfp;
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ length,
+ RESPECT_LIMITS,
+ DONT_INIT_KEY) )
+ {
+ goto done;
+ }
+
+ switch(file->access)
+ {
+ case file_access_seq_e:
+ {
+ // Check that the prior operation was a successful read:
+ if( rfp.current_file_position != file->prior_read_location )
+ {
+ file->io_status = FsNoRead; // "43"
+ goto done;
+ }
+
+ // Turn that valid record into an empty one:
+ record_marker = 0x00;
+ pwrite(rfp.fd, &record_marker, 1, rfp.flag_position);
+ handle_ferror(file, __func__, "pwrite() error");
+ break;
+ }
+
+ case file_access_rnd_e:
+ case file_access_dyn_e:
+ {
+ // We are doing a random access:
+
+ // Let's check to make sure the slot for this record is currently occupied:
+
+ pread(rfp.fd, &record_marker, 1, rfp.flag_position);
+ if( handle_ferror(file, __func__, "pread() error") )
+ {
+ goto done;
+ }
+
+ if( record_marker != internal_newline )
+ {
+ // There isn't a record there for us to delete, which is an error
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+
+ // We now clobber the 0x0A record marker:
+ record_marker = 0x00;
+ pwrite(rfp.fd, &record_marker, 1, rfp.flag_position);
+ if( handle_ferror(file, __func__, "pwrite() error") )
+ {
+ goto done;
+ }
+ break;
+ }
+
+ default:
+ warnx("%s(): unhandled access mode %d\n", __func__, file->access);
+ exit(1);
+ break;
+ }
+
+ done:
+ establish_status(file, -1);
+ }
+
+static std::vector<unsigned char>
+file_indexed_make_key(const unsigned char *location, int length)
+ {
+ std::vector<unsigned char> retval;
+ for(int i = 0; i < length; i++ )
+ {
+ retval.push_back(*location++);
+ }
+ return retval;
+ }
+
+static long
+file_indexed_find_key( cblc_file_t *file,
+ const unsigned char *location,
+ int length,
+ int index)
+ {
+ // We need to build the index entry for the primary key:
+ std::vector<unsigned char> key = file_indexed_make_key(location, length);
+
+ // We now need to see if this key is in indices[index];
+ long retval = -1;
+
+ std::pair <std::multimap<std::vector<unsigned char>, long>::iterator, std::multimap<std::vector<unsigned char>, long>::iterator> ret;
+ ret = file->p_indexed->indices[index]->key_to_position.equal_range(key);
+
+ if( ret.first != ret.second )
+ {
+ retval = ret.first->second;
+ file->p_indexed->indices[index]->recent_iterator = ret.first;
+ file->p_indexed->indices[index]->recent_iterator++;
+ }
+ else
+ {
+ file->p_indexed->indices[index]->recent_iterator = file->p_indexed->indices[index]->key_to_position.end();
+ }
+ return retval;
+ }
+
+static void
+file_indexed_delete(cblc_file_t *file)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ cblc_field_t *record_area = file->default_record;
+ int save_the_index = file->p_indexed->recent_index;
+ size_t ncount;
+ long fpos;
+ long starting_position = ftell(file->file_pointer);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ starting_position = -1;
+ goto done;
+ }
+
+ if( !file->file_pointer )
+ {
+ // Attempting to delete in a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoDelete; // "49"
+ goto done;
+ }
+
+ if( file->mode_char != '+' )
+ {
+ // We have to be in I-O mode
+ errno = EBADF;
+ file->io_status = FsNoDelete; // "49"
+ goto done;
+ }
+
+ // We need to delete a record based on its primary key
+ fpos = file_indexed_find_key( file,
+ file->p_indexed->indices[0]->the_key->data,
+ file->p_indexed->indices[0]->the_key->capacity,
+ 0);
+ if( fpos == -1 )
+ {
+ // The primary key does not exist
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+
+ // In order to remove the keys from the maps, we need the record:
+ fseek(file->file_pointer, fpos, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ fread(record_area->data, 1, file->record_area_size, file->file_pointer);
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ goto done;
+ }
+
+ // There is a good record sitting in the record area. We need to
+ // remove it from all of the indices.
+
+ for( size_t i=0; i< file->p_indexed->indices.size(); i++)
+ {
+ // Build the key we need from the data in the record_area
+ std::vector<unsigned char> the_key = file_indexed_make_key( record_area->data + file->p_indexed->indices[i]->the_key->offset,
+ file->p_indexed->indices[i]->the_key->capacity);
+
+ // Find the range of entries with this key
+ std::pair <std::multimap<std::vector<unsigned char>, long>::iterator, std::multimap<std::vector<unsigned char>, long>::iterator> ret;
+ ret = file->p_indexed->indices[i]->key_to_position.equal_range(the_key);
+
+ // ret is a pair of iterators
+ while(ret.first != ret.second)
+ {
+ if( ret.first->second == fpos )
+ {
+ // This iterator has the fpos we are eliminating:
+ file->p_indexed->indices[i]->key_to_position.erase(ret.first);
+ break;
+ }
+ }
+ }
+
+ // The maps have all had the relevant keys removed; there's nothing
+ // left but to turn this record into a hole by filling it, and the final
+ // two extra characters, with zeroes.
+
+ fseek(file->file_pointer, fpos, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ ncount = file->record_area_size + 2;
+ while(ncount--)
+ {
+ fputc(internal_space, file->file_pointer);
+ if( handle_ferror(file, __func__, "fputc() error") )
+ {
+ goto done;
+ }
+ }
+ // We just created a hole; put it in the list:
+ file->p_indexed->holes.push_back(fpos);
+
+ done:
+ if( starting_position != -1 )
+ {
+ // The specification says that DELETE doesn't change the
+ // file position indicator:
+ fseek(file->file_pointer, starting_position, SEEK_SET);
+ handle_ferror(file, __func__, "fseek() error");
+ }
+ file->p_indexed->recent_index = save_the_index;
+ establish_status(file, -1);
+ }
+
+
+extern "C"
+void
+__gg__file_delete( cblc_file_t *file,
+ size_t length )
+ {
+ switch(file->org)
+ {
+ case file_relative_e:
+ file_relative_delete(file, length);
+ break;
+
+ case file_indexed_e:
+ file_indexed_delete(file);
+ break;
+
+ default:
+ warnx("%s(): Unhandled file organization", __func__);
+ exit(1);
+ break;
+ }
+ }
+
+static int
+file_indexed_compare_keys(const std::vector<unsigned char> &key1, const std::vector<unsigned char> &key2)
+ {
+ int retval = 0;
+
+ for(size_t i=0; i<key1.size() && i<key2.size(); i++)
+ {
+ if( key1[i] < key2[i] )
+ {
+ retval = -1;
+ break;
+ }
+ else if( key1[i] > key2[i] )
+ {
+ retval = 1;
+ break;
+ }
+ }
+
+ return retval;
+ }
+
+static int
+file_indexed_find_index(cblc_file_t *file, cblc_field_t *key_field)
+ {
+ size_t recent_index;
+ int retval = -1;
+ for( recent_index=0; recent_index < file->p_indexed->indices.size(); recent_index++ )
+ {
+ if( file->p_indexed->indices[recent_index]->the_key == key_field )
+ {
+ retval = (int)recent_index;
+ file->p_indexed->recent_index = retval;
+ }
+ }
+ return retval;
+ }
+
+static void
+file_indexed_start( cblc_file_t *file,
+ int relop,
+ cblc_refer_t *resolved_key_ )
+ {
+ file->io_status = FsNotFound; // "23"
+ int recent_index = file_indexed_find_index(file, resolved_key_->field);
+ if( recent_index != -1 )
+ {
+ file->p_indexed->recent_index = recent_index;
+
+ cblc_resolved_t resolved_key;
+ __gg__refer_resolve(resolved_key_, &resolved_key);
+
+ std::vector<unsigned char> desired_key
+ = file_indexed_make_key(resolved_key.location,
+ resolved_key.length_untrimmed);
+
+ for(std::multimap<std::vector<unsigned char>, long>::iterator it = file->p_indexed->indices[recent_index]->key_to_position.begin();
+ it != file->p_indexed->indices[recent_index]->key_to_position.end();
+ it++ )
+ {
+ file->p_indexed->indices[recent_index]->recent_iterator = it;
+ int des_to_key = file_indexed_compare_keys( it->first, desired_key);
+ switch(relop)
+ {
+ case eq_op: // EQUAL
+ if( des_to_key == 0 )
+ {
+ file->io_status = FsErrno;
+ goto found_it;
+ }
+ break;
+
+ case gt_op: // GREATER
+ if( des_to_key > 0 )
+ {
+ file->io_status = FsErrno;
+ goto found_it;
+ }
+ break;
+
+ case ge_op: // NOT LESS THAN, or GREATER THAN OR EQUAL TO
+ if( des_to_key >= 0 )
+ {
+ file->io_status = FsErrno;
+ goto found_it;
+ }
+ break;
+ }
+ }
+ found_it:;
+ }
+ }
+
+extern "C"
+void __gg__file_start( cblc_file_t *file,
+ int relop,
+ cblc_refer_t *key )
+ {
+ // According to IBM Language Reference, whether or not 'key' is specified,
+ // the value used is from the RELATIVE KEY clause. See page 421 "Relative Files"
+ // "Whether or not the KEY phrase is specified, the key data item used in the
+ // comparison is the RELATIVE KEY data item."
+ errno = 0;
+ file->io_status = FsErrno;
+
+ relative_file_parameters rfp;
+ bool okay;
+
+ if( !file->file_pointer )
+ {
+ // Attempting to read a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoRead; // "43"
+ goto done;
+ }
+
+ okay = (file->org == file_indexed_e || file->org == file_relative_e)
+ && (file->access == file_access_seq_e || file->access == file_access_dyn_e)
+ && (file->mode_char == 'r' || file->mode_char == '+') ;
+ if( !okay )
+ {
+ errno = EBADF;
+ file->io_status = FsNoRead; // "43"
+ goto done;
+ }
+
+ if( file->org == file_relative_e )
+ {
+ int hyphen;
+ int rdigits;
+ long total_record_length;
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ file->record_area_size,
+ IGNORE_LIMITS,
+ INIT_KEY) )
+ {
+ goto done;
+ }
+ total_record_length = rfp.preamble_size + rfp.payload_size + rfp.postamble_size;
+
+ rfp.key_value = (long)__gg__binary_value_from_field(&hyphen, &rdigits, file->keys[0]);
+ switch( relop )
+ {
+ case eq_op:
+ case ge_op:
+ break;
+ case gt_op:
+ rfp.key_value += 1;
+ break;
+ default:
+ warnx("%s(): relop is %d, which we don't know how to handle", __func__, relop);
+ exit(1);
+ break;
+ }
+ rfp.record_position = (rfp.key_value-1) * total_record_length;
+ if( rfp.record_position<0 || rfp.record_position+total_record_length > rfp.file_size )
+ {
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+ // Position the file at the requested record:
+ fseek(file->file_pointer, rfp.record_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+ else
+ {
+ file_indexed_start(file, relop, key);
+ }
+
+ done:
+ establish_status(file, -1);
+ }
+
+
+static void
+file_relative_rewrite( cblc_file_t *file,
+ cblc_refer_t *field_ )
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ long starting_position;
+ relative_file_parameters rfp;
+ bool okay;
+
+ if( !file->file_pointer )
+ {
+ // Attempting to read a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ okay = file->mode_char == '+'
+ && ( file->org == file_sequential_e
+ || file->org == file_indexed_e
+ || file->org == file_relative_e ) ;
+
+ if( !okay )
+ {
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ starting_position = ftell(file->file_pointer);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ goto done;
+ }
+
+ switch( file->org )
+ {
+ case file_sequential_e:
+ {
+ rewrite_sequential:
+ if( file->prior_read_location == -1 )
+ {
+ // The prior operation was not a successful read:
+ file->io_status = FsNoRead; // "43"
+ goto done;
+ }
+
+ // We now overwrite the record in the file with the data in field:
+ fseek(file->file_pointer, file->prior_read_location, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ cblc_resolved_t field;
+ __gg__refer_resolve(field_, &field);
+
+ fwrite( field.location,
+ field.length_trimmed,
+ 1,
+ file->file_pointer );
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+
+ break;
+ }
+
+ case file_relative_e:
+ switch( file->access )
+ {
+ case file_access_seq_e:
+ // This is the same as for file_sequential_e
+ goto rewrite_sequential;
+ break;
+
+ case file_access_rnd_e:
+ case file_access_dyn_e:
+ {
+ // This is like a write, except the place we are putting
+ // it has to be occupied instead of empty.
+ char record_marker;
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ file->record_area_size,
+ RESPECT_LIMITS, DONT_INIT_KEY) )
+ {
+ goto done;
+ }
+ pread(rfp.fd, &record_marker, 1, rfp.flag_position);
+ if( handle_ferror(file, __func__, "pread() error") )
+ {
+ goto done;
+ }
+ if( record_marker != internal_newline )
+ {
+ // The record is not specified:
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+
+ fseek(file->file_pointer, rfp.record_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ // We can overwrite the valid record:
+ cblc_resolved_t field;
+ __gg__refer_resolve(field_, &field);
+ fwrite( field.location,
+ field.length_untrimmed,
+ 1,
+ file->file_pointer );
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+ break;
+ }
+
+ default:
+ warnx("%s(): We don't know how to handle access mode %d\n", __func__, file->access);
+ exit(1);
+ break;
+
+ }
+ break;
+
+ default:
+ warnx("%s(): Can't handle file_indexed_e\n", __func__);
+ exit(1);
+ break;
+ }
+
+ // Per the standard, return the file location pointer back to whence it came:
+ fseek(file->file_pointer, starting_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ done:
+ establish_status(file, -1);
+ }
+
+static void
+file_indexed_rewrite( cblc_file_t *file,
+ cblc_refer_t *field_ )
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ long starting_position = -1;
+ long fpos;
+
+ if( !file->file_pointer )
+ {
+ // Attempting to work on a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ if( file->mode_char != '+' )
+ {
+ // For an indexed_file REWRITE, the mode has to be '+'
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ starting_position = ftell(file->file_pointer);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ goto done;
+ }
+
+ if( file->prior_read_location == -1 )
+ {
+ // The prior operation was not a successful read:
+ file->io_status = FsNoRead; // "43"
+ goto done;
+ }
+
+ // We now know that the prior operation was a successful read into
+ // file->prior_read_location.
+
+ // Let's move (if necessary), the given field into the record_area:
+
+ cblc_resolved_t field;
+ __gg__refer_resolve(field_, &field);
+ if( file->default_record->data != field.location )
+ {
+ // The starting locations are different, so let's make the move:
+ size_t bytes_to_move = field.length_trimmed;
+ if( file->record_area_size < bytes_to_move )
+ {
+ bytes_to_move = file->record_area_size;
+ }
+
+ memmove(file->default_record->data, field.location, bytes_to_move);
+ }
+
+ // Programmers are sneaky devils, so we have to make sure the keys for the
+ // new data for this slot are valid:
+
+ // First, the primary key:
+ fpos = file_indexed_find_key( file,
+ file->keys[0]->data,
+ file->keys[0]->capacity,
+ 0);
+ if( fpos != file->prior_read_location)
+ {
+ // The primary key was changed between the READ and now:
+ file->io_status = FsKeySeq; // "21"
+ goto done;
+ }
+
+ // The primary key is okay; let's check the alternate keys:
+
+ for( size_t i=1; i<file->p_indexed->indices.size(); i++ )
+ {
+ if( file->uniques[i] )
+ {
+ // This key has to be unique:
+ if( file_indexed_find_key( file,
+ file->keys[i]->data,
+ file->keys[i]->capacity,
+ i) != fpos )
+ {
+ // This would create a duplicate UNIQUE key
+ file->io_status = FsDupWrite; // "22"
+ goto done;
+ }
+ }
+ }
+
+ // We can now write the data out, at the given location:
+
+ fseek(file->file_pointer, fpos, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ fwrite( file->default_record->data,
+ file->record_area_size,
+ 1,
+ file->file_pointer );
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+
+ done:
+ // Per the standard, return the file location pointer back to whence it came:
+ if( starting_position != -1 )
+ {
+ fseek(file->file_pointer, starting_position, SEEK_SET);
+ handle_ferror(file, __func__, "fseek() error");
+ }
+ establish_status(file, -1);
+ }
+
+extern "C"
+void __gg__file_rewrite(cblc_file_t *file,
+ cblc_refer_t *field )
+ {
+ switch(file->org)
+ {
+ case file_relative_e:
+ file_relative_rewrite(file, field);
+ break;
+
+ case file_indexed_e:
+ file_indexed_rewrite(file, field);
+ break;
+
+ default:
+ warnx("%s(): Unhandled file organization", __func__);
+ exit(1);
+ break;
+ }
+ }
+
+static void
+file_relative_write(cblc_file_t *file,
+ unsigned char *location,
+ size_t length)
+ {
+ // This routine handles writes to RELATIVE files
+
+ errno = 0;
+ file->io_status = FsErrno;
+
+ long necessary_file_size;
+ char achPostamble[] = {internal_cr, internal_newline};
+
+ // Check to make sure the WRITE is consistent with the mode:
+ // See ISO spec 14.9.47.3, sentence 1
+ if( file->access == file_access_seq_e )
+ {
+ // sequential mode is OUTPUT or EXTEND
+ if( file->mode_char != 'w' && file->mode_char != 'a' )
+ {
+ file->io_status = FsNoWrite; // "48"
+ establish_status(file, -1);
+ return;
+ }
+ }
+ // Otherwise (access is random or dynamic) it has to be OUTPUT or I-O
+ if( file->mode_char != 'w' && file->mode_char != '+' )
+ {
+ file->io_status = FsNoWrite; // "48"
+ establish_status(file, -1);
+ return;
+ }
+
+ relative_file_parameters rfp;
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ length,
+ IGNORE_LIMITS,
+ DONT_INIT_KEY) )
+ {
+ goto done;
+ }
+
+ necessary_file_size = rfp.record_position + rfp.preamble_size + rfp.payload_size + rfp.postamble_size;
+ if( rfp.file_size < necessary_file_size )
+ {
+ // Position the file position indicator to the very end of the file
+ fseek(file->file_pointer, 0, SEEK_END);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ // Expand the file to the necessary lenght:
+ while( rfp.file_size++ < necessary_file_size-1 )
+ {
+ fputc(0, file->file_pointer);
+ if( handle_ferror(file, __func__, "fputc() error") )
+ {
+ goto done;
+ }
+ }
+ }
+ // Let's check to make sure the slot for this record is currently available:
+ char record_marker;
+ pread(rfp.fd, &record_marker, 1, rfp.flag_position);
+ if( handle_ferror(file, __func__, "pread() error") )
+ {
+ goto done;
+ }
+
+ if( record_marker == internal_newline )
+ {
+ // The slot has something in it already:
+ file->io_status = FsDupWrite; // "22"
+ goto done;
+ }
+
+ // Position the file pointer at the slot:
+ fseek(file->file_pointer, rfp.record_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ // Write out the data:
+ fwrite(location, length, 1, file->file_pointer);
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+
+ // Write out the rfm_microfocus "valid record" postamble:
+ fwrite(achPostamble, 1, 2, file->file_pointer);
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+
+ // Per the COBOL specification, put the file position back to where
+ // it was when we started this exercise:
+ fseek(file->file_pointer, rfp.current_file_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek(starting_pos) error") )
+ {
+ goto done;
+ }
+
+ done:
+ establish_status(file, -1);
+ }
+
+static bool
+file_indexed_update_indices(cblc_file_t *file, const unsigned char *record_buffer, long record_position)
+ {
+ // We need to build the index entry for each key:
+
+ bool retval = true; // This means it was okay
+
+ int recent_index = 0;
+ cblc_field_t **key = file->keys;
+ int *unique = file->uniques;
+
+ while(*key)
+ {
+ if( *unique )
+ {
+ // This index is flagged as UNIQUE, so...
+ long fpos = file_indexed_find_key( file,
+ record_buffer + file->keys[recent_index]->offset,
+ file->keys[recent_index]->capacity,
+ recent_index);
+ if( fpos != -1 )
+ {
+ // ...DUPLICATES are not allowed
+ file->io_status = FsDupWrite; // "22"
+ retval = false;
+ break;
+ }
+ }
+ std::vector<unsigned char> index_key = file_indexed_make_key(record_buffer + file->keys[recent_index]->offset,
+ file->keys[recent_index]->capacity);
+ // insert the key/position pair into the multimap
+ file->p_indexed->indices[recent_index]->key_to_position.insert( std::pair<std::vector<unsigned char>, long>(index_key, record_position) );
+
+ key += 1;
+ unique += 1;
+ recent_index += 1;
+ }
+ return retval;
+ }
+
+static void
+file_indexed_write( cblc_file_t *file,
+ unsigned char *location,
+ size_t length)
+ {
+ // This routine handles FILE WRITE to INDEXED files
+
+ // At this writing, we are doing ifm_dubner_e. The data file is identical
+ // to the relative file: There are two extra bytes at the end of each
+ // record. The final byte is internal_newline for a valid record.
+
+ // The functional difference is that for each record we write, we update
+ // the index tables that we keep in memory; there is no separate index
+ // file
+
+ errno = 0;
+ file->io_status = FsErrno;
+ long position_to_write;
+
+ char achPostamble[] = {internal_cr, internal_newline};
+
+ // Check to make sure the WRITE is consistent with the mode:
+ if( file->access == file_access_seq_e )
+ {
+ // sequential mode is OUTPUT or EXTEND. We can only add things at the end
+ if( file->mode_char != 'w' && file->mode_char != 'a' )
+ {
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+ // The primary key for a new record has to be greater than the biggest
+ // existing one:
+ if( file->p_indexed->indices[0]->key_to_position.size() == 0 )
+ {
+ // We are dealing with an empty file, so we'll be writing at
+ // starting_position, which is set to the end
+ }
+ else
+ {
+ std::multimap<std::vector<unsigned char>, long>::const_reverse_iterator last_element =
+ file->p_indexed->indices[0]->key_to_position.crbegin();
+ std::vector<unsigned char> biggest_key = last_element->first;
+
+ // Quick & dirty comparison to make sure our new key is greater than
+ // the biggest_key:
+
+ unsigned char *new_key = location + file->keys[0]->offset;
+ bool okay = false;
+ for( size_t i=0; i<biggest_key.size(); i++ )
+ {
+ if( new_key[i] > biggest_key[i] )
+ {
+ okay = true;
+ }
+ }
+ if( !okay )
+ {
+ // Create out-of-sequence INVALID KEY condition
+ file->io_status = FsKeySeq; // "21"
+ goto done;
+ }
+ // We are allowed to do the write. Because this is "w" or "a",
+ // it will be at the end
+ }
+ }
+ else
+ {
+ // Because access is random or dynamic the mode has to be OUTPUT or I-O
+ if( file->mode_char != 'w' && file->mode_char != '+' )
+ {
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ // This record is not in the data file; figure out where to put it
+ if( file->mode_char == '+' )
+ {
+ // This is a '+' for I-O, so we can write into a hole:
+ if( file->p_indexed->holes.size() )
+ {
+ position_to_write = file->p_indexed->holes.back();
+ file->p_indexed->holes.pop_back();
+ fseek(file->file_pointer, position_to_write, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+ else
+ {
+ // There is no hole, so make sure we are writing at the end
+ fseek(file->file_pointer, 0, SEEK_END);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+ }
+ }
+
+ // In order to do a successful WRITE, we need to make sure that none of
+ // the UNIQUE keys would end up being duplicated:
+ for( size_t i=0; i<file->p_indexed->indices.size(); i++ )
+ {
+ if( file->uniques[i] )
+ {
+ // This key has to be unique:
+ if( file_indexed_find_key( file,
+ location + file->keys[i]->offset,
+ file->keys[i]->capacity,
+ i) != -1 )
+ {
+ // This would create a duplicate UNIQUE key
+ file->io_status = FsDupWrite; // "22"
+ goto done;
+ }
+ }
+ }
+
+ position_to_write = ftell(file->file_pointer);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ goto done;
+ }
+
+ // We are currently located where the new data must be written:
+ // Write out the data:
+ fwrite(location, length, 1, file->file_pointer);
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+
+ // Write out the rfm_microfocus "valid record" postamble:
+ fwrite(achPostamble, 1, 2, file->file_pointer);
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+ file_indexed_update_indices(file, location, position_to_write);
+
+ done:
+ establish_status(file, -1);
+ }
+
+extern "C"
+void
+__gg__file_write( cblc_file_t *file,
+ cblc_field_t * /*data_source*/,
+ unsigned char *location,
+ size_t length,
+ int after,
+ int lines)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+ char ch;
+ int characters_to_write;
+
+ if( !file->file_pointer )
+ {
+ // Attempting to read a file that isn't open
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ if( file->mode_char != 'w' && file->mode_char != '+' && file->mode_char != 'a' )
+ {
+ // File is open, but not in I-O, OUTPUT, or EXTEND mode
+ errno = EBADF;
+ file->io_status = FsNoWrite; // "48"
+ goto done;
+ }
+
+ switch(file->org)
+ {
+ case file_line_sequential_e:
+ case file_sequential_e:
+ break;
+
+ case file_relative_e:
+ {
+ return file_relative_write(file, location, length);
+ break;
+ }
+
+ case file_indexed_e:
+ {
+ return file_indexed_write(file, location, length);
+ break;
+ }
+
+ default:
+ fprintf(stderr, "%s(): Unhandled cbl_file_org_t %d\n", __func__, file->org);
+ exit(1);
+ break;
+ }
+
+ // This code handles SEQUENTIAL and LINE SEQUENTIAl
+
+ ch = internal_newline;
+
+ // By default, we write out the number of characters in the record area
+ characters_to_write = length;
+
+ // That gets overridden if there is a record_length
+ if( file->record_length )
+ {
+ int hyphen;
+ int rdigits;
+ characters_to_write = (int)__gg__binary_value_from_field(&hyphen, &rdigits, file->record_length);
+ }
+
+ if( file->org == file_line_sequential_e )
+ {
+ // If file-sequential, then trailing spaces are removed:
+ while( characters_to_write > 0
+ && location[characters_to_write-1] == internal_space )
+ {
+ characters_to_write -= 1;
+ }
+ }
+
+ if( lines < 0 )
+ {
+ ch = internal_ff; // Form feed
+ lines = 1;
+ }
+
+ if( after )
+ {
+ // We have to print the internal_newlines, so that we can print the guts AFTER
+ while(lines--)
+ {
+ fputc(ch, file->file_pointer);
+ if( handle_ferror(file, __func__, "fputc() error [1]") )
+ {
+ goto done;
+ }
+ }
+ }
+
+ switch(file->org)
+ {
+ case file_line_sequential_e:
+ case file_sequential_e:
+ if( characters_to_write )
+ {
+ fwrite( location,
+ characters_to_write,
+ 1,
+ file->file_pointer);
+ }
+ if( handle_ferror(file, __func__, "fwrite() error") )
+ {
+ goto done;
+ }
+ break;
+
+ default:
+ fprintf(stderr, "%s(): Unhandled cbl_file_org_t %d\n", __func__, file->org);
+ exit(1);
+ break;
+ }
+
+ if( !after )
+ {
+ // We did the output BEFORE, so now it's time to send some internal_newlines
+ while(lines--)
+ {
+ fputc(ch, file->file_pointer);
+ if( handle_ferror(file, __func__, "fputc() error [2]") )
+ {
+ goto done;
+ }
+ }
+ }
+
+ done:
+ establish_status(file, -1);
+ }
+
+static void
+file_line_sequential_read( cblc_file_t *file,
+ cblc_refer_t *data_dest_)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+ size_t characters_read = 0;
+ size_t remaining;
+
+ // According to IBM:
+
+ // Characters are read one at a time until:
+ // - A delimiter is reached. It is discarded, and the
+ // record area is filled with spaces.
+ // - The entire record area is filled. If the next unread
+ // character is the delimiter, it is discarded. Otherwise,
+ // it becomes the first character read by the next READ
+ // - EOF is encountered; the remainder of the record area
+ // is filled with spaces.
+
+ // This contradicts the ISO/IEC 2014 standard, which says
+ // in section 14.9.29.3, paragraph 14) on page 554 that excess
+ // characters are discarded, and too-short records have
+ // characters to the right as undefined. I'm going with IBM,
+ // it makes more sense to me.
+
+ // We first stage the data into the record area.
+ int ch;
+
+ while( characters_read < file->record_area_size )
+ {
+ ch = fgetc(file->file_pointer);
+ if( handle_ferror(file, __func__, "fgetc() error") )
+ {
+ goto done;
+ }
+ if( ch == file->delimiter || ch == EOF )
+ {
+ break;
+ }
+ file->default_record->data[characters_read] = (char)ch;
+ characters_read += 1;
+ }
+ remaining = characters_read;
+ while(remaining < file->record_area_size )
+ {
+ // Space fill shorty records
+ file->default_record->data[remaining++] = internal_space;
+ }
+
+ cblc_resolved_t data_dest;
+ __gg__refer_resolve(data_dest_, &data_dest);
+
+ // We now transfer data from the record_area to data_dest:
+ if( file->default_record->data != data_dest.location )
+ {
+ size_t bytes_to_move = file->record_area_size;
+ if( data_dest.length_untrimmed < bytes_to_move )
+ {
+ bytes_to_move = data_dest.length_untrimmed;
+ }
+ memmove(data_dest.location, file->default_record->data, bytes_to_move);
+ }
+
+ if( feof(file->file_pointer) && !characters_read)
+ {
+ // We got an end-of-file without characters
+ file->io_status = FsEofSeq; // "10"
+ }
+ else if( feof(file->file_pointer) )
+ {
+ // We got an end-of-file whilst reading characters
+ // Override the FsEofSeq. We'll get an actual EOF if the programmer
+ // does another READ:
+ file->io_status = FsErrno;
+ }
+ else if (characters_read < file->record_area_size)
+ {
+ // Just discard an early record delimiter
+ file->io_status = FsRecordLength; // "04"
+ }
+ else // We filled the whole record area. Look ahead one character
+ {
+#if 0
+ // In this code, unread characters before the internal_newline
+ // are read next time. See page 133 of the IBM Language Reference
+ // Manual: "If the first unread character is the record delimiter, it
+ // is discarded. Otherwise, the first unread character becomes the first
+ // character read by the next READ statement."
+ ch = fgetc(file->file_pointer);
+ // If that next character isn't a delimiter, put it back:
+ if( handle_ferror(file->file_pointer, __func__, "fgetc() error") )
+ {
+ goto done;
+ }
+ if( ch != file->delimiter && ch != EOF)
+ {
+ ungetc(ch, file->file_pointer);
+ }
+#else
+ // In this code, extra characters before the internal_newline
+ // are read next time are discarded. GnuCOBOL works this way, and
+ // the Michael Coughlin "Beginning COBOL" examples require this mode.
+ // The ISO/IEC 2014 standard is silent on the question of LINE
+ // SEQUENTIAL; it describes only SEQUENTIAL.
+ for(;;)
+ {
+ ch = fgetc(file->file_pointer);
+ // We can't use handle_ferror() directly, because an EOF is
+ // a legitimate way to end the last line.
+ if( ferror(file->file_pointer) && handle_ferror(file, __func__, "fgetc() error") )
+ {
+ goto done;
+ }
+ if( ch == file->delimiter || ch == EOF)
+ {
+ break;
+ }
+ file->io_status = FsRecordLength; // "04"
+ }
+#endif
+ }
+
+ if( file->record_length )
+ {
+ __gg__scale_and_assign_to_field(file->record_length,
+ characters_read,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ done:
+ establish_status(file, -1);
+ }
+
+static void
+file_sequential_read( cblc_file_t *file,
+ cblc_refer_t *data_dest_)
+ {
+ // In sequential access mode there are no end-of-line markers. Reading
+ // is based on the target data size
+ errno = 0;
+ file->io_status = FsErrno;
+
+ size_t characters_read = 0;
+
+ cblc_resolved_t data_dest;
+ __gg__refer_resolve(data_dest_, &data_dest);
+
+ memset(data_dest.location, internal_space, data_dest.length_untrimmed);
+ characters_read = fread(data_dest.location, 1, data_dest.length_untrimmed, file->file_pointer);
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ goto done;
+ }
+ if( handle_feof(file) )
+ {
+ goto done;
+ }
+
+ if( characters_read && characters_read < data_dest.length_untrimmed )
+ {
+ file->io_status = FsRecordLength; // "04"
+ }
+
+ if( file->record_length )
+ {
+ __gg__scale_and_assign_to_field(file->record_length,
+ characters_read,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ done:
+ establish_status(file, -1);
+ }
+
+static void
+file_relative_read( cblc_file_t *file,
+ cblc_refer_t *data_dest_,
+ int next_record)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ if( file->access == file_access_seq_e )
+ {
+ // Force sequential access RELATIVE files into NEXT RECORD mode
+ next_record = 1;
+ }
+
+ relative_file_parameters rfp;
+
+ size_t characters_read = 0;
+ long fpos = -1;
+ long record_length;
+
+ cblc_resolved_t data_dest;
+ __gg__refer_resolve(data_dest_, &data_dest);
+
+ if( !next_record )
+ {
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ data_dest.length_untrimmed,
+ RESPECT_LIMITS,
+ DONT_INIT_KEY) )
+ {
+ goto done;
+ }
+ record_length = rfp.preamble_size + rfp.payload_size + rfp.postamble_size;
+ fseek(file->file_pointer, rfp.record_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+ else
+ {
+ // This is a sequential read of a RELATIVE file
+ long max_pos;
+ if( relative_file_parameters_get( rfp,
+ rfm_microfocus_e,
+ file,
+ data_dest.length_untrimmed,
+ IGNORE_LIMITS,
+ INIT_KEY) )
+ {
+ goto done;
+ }
+ record_length = rfp.preamble_size + rfp.payload_size + rfp.postamble_size;
+
+ max_pos = (__gg__power_of_ten(file->keys[0]->digits)-1) * record_length ;
+ if( rfp.current_file_position >= max_pos )
+ {
+ // This is an oddball error: A sequential read would result in reading a record
+ // whose relative record number is too big for file->key to hold
+ file->io_status = FsEofRel; // "14"
+ goto done;
+ }
+ }
+
+ // The following code is predicated on rfm_microfocus_e.
+
+ // We are now poised to read a record, provided the flag byte is internal_newline
+ for(;;)
+ {
+ if( !rfp.inside_existing_file )
+ {
+ file->io_status = FsEofSeq; // "10"
+ goto done;
+ }
+ char record_marker;
+ pread(rfp.fd, &record_marker, 1, rfp.flag_position);
+ if( handle_ferror(file, __func__, "pread() error") )
+ {
+ goto done;
+ }
+ if(record_marker == internal_newline)
+ {
+ // We have a good record to read:
+ // Space out the user's receive space
+ memset(data_dest.location, internal_space, data_dest.length_untrimmed);
+
+ // We need to change the file_position_pointer to reflect any
+ // preamble:
+ if( rfp.preamble_size )
+ {
+ fseek(file->file_pointer, rfp.preamble_size, SEEK_CUR);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+ // Read the characters into the receive space
+ characters_read = fread(data_dest.location,
+ 1,
+ data_dest.length_untrimmed,
+ file->file_pointer);
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ goto done;
+ }
+ // We need to change the file_position_pointer to reflect any
+ // postamble:
+ if( rfp.postamble_size )
+ {
+ fseek(file->file_pointer, rfp.postamble_size, SEEK_CUR);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ }
+
+ // And having read that that data, we are done here
+ fpos = rfp.current_file_position;
+ break;
+ }
+ else
+ {
+ // There isn't a record in this slot
+ if( next_record )
+ {
+ // But we are in next_record mode. It is our duty and obligation
+ // to skip merrily through the file looking for the next valid
+ // record for the lazy bums who called us.
+ rfp.record_position += record_length;
+ rfp.flag_position += record_length;
+ rfp.inside_existing_file = rfp.current_file_position + record_length <= rfp.file_size;
+
+ fseek(file->file_pointer, rfp.record_position, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+ rfp.current_file_position = rfp.record_position;
+ continue;
+ }
+ break;
+ }
+ }
+
+ if( characters_read == 0 )
+ {
+ file->io_status = FsNotFound; // "23"
+ }
+ done:
+ if( file->record_length )
+ {
+ __gg__scale_and_assign_to_field(file->record_length,
+ characters_read,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ establish_status(file, fpos);
+ }
+
+static void
+file_indexed_read( cblc_file_t *file,
+ cblc_refer_t *key,
+ cblc_refer_t *data_dest_,
+ int next_record)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ size_t characters_read = 0;
+ long fpos=-1;
+
+ if( file->access == file_access_seq_e )
+ {
+ // Force sequential access RELATIVE files into NEXT RECORD mode
+ next_record = 1;
+ }
+
+ if( !next_record )
+ {
+ // It is meat and potatoes time. We need to pick up the first record
+ // with the specified key:
+
+ int next_index = file_indexed_find_index(file, key->field);
+ if( next_index == -1 )
+ {
+ warnx("%s(): This probably shouldn't have happened", __func__);
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+
+ fpos = file_indexed_find_key( file,
+ key->field->data,
+ key->field->capacity,
+ next_index);
+ if( fpos == -1 )
+ {
+ file->io_status = FsNotFound; // "23"
+ goto done;
+ }
+ }
+ else
+ {
+ // We are ready to do a sequential read of an INDEXED file
+ int recent_index = file->p_indexed->recent_index;
+
+ if( file->p_indexed->indices[recent_index]->recent_iterator
+ == file->p_indexed->indices[recent_index]->key_to_position.end() )
+ {
+ // We have hit the end of keys
+ file->io_status = FsEofSeq; // "10"
+ goto done;
+ }
+ fpos = file->p_indexed->indices[recent_index]->recent_iterator->second;
+ file->p_indexed->indices[recent_index]->recent_iterator++;
+ }
+
+ // fpos is where the data are:
+ fseek(file->file_pointer, fpos, SEEK_SET);
+ if( handle_ferror(file, __func__, "fseek() error") )
+ {
+ goto done;
+ }
+
+ cblc_resolved_t data_dest;
+ __gg__refer_resolve(data_dest_, &data_dest);
+
+ characters_read = fread(data_dest.location,
+ 1,
+ data_dest.length_untrimmed,
+ file->file_pointer);
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ goto done;
+ }
+
+ done:
+ if( file->record_length )
+ {
+ __gg__scale_and_assign_to_field(file->record_length,
+ characters_read,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ establish_status(file, fpos);
+ }
+
+extern "C"
+void
+__gg__file_read(cblc_file_t *file,
+ cblc_refer_t *data_dest,
+ cblc_refer_t *key,
+ int next_record)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+
+ if( !(file->flags & file_flag_existed_e) && (file->flags & file_flag_optional_e))
+ {
+ // Trying to read a file that didn't exist during file_open.
+ if( file->org == file_sequential_e || file->org == file_line_sequential_e )
+ {
+ file->io_status = FsEofSeq; // "10"
+ errno = EBADF;
+ establish_status(file, -1);
+ return;
+ }
+ else
+ {
+ // The indexed or relative file didn't exist, so set an INVALID KEY
+ // condition:
+ file->io_status = FsNotFound; // "23"
+ errno = EBADF;
+ establish_status(file, -1);
+ return;
+ }
+ }
+
+ if( !file->file_pointer )
+ {
+ // Attempting to read a file that isn't open
+ file->io_status = FsReadNotOpen; // "47"
+ errno = EBADF;
+ establish_status(file, -1);
+ return;
+ }
+
+ if( file->mode_char != 'r' && file->mode_char != '+' )
+ {
+ // The file is open, but not in INPUT or I-O mode:
+ file->io_status = FsReadNotOpen; // "47"
+ errno = EBADF;
+ establish_status(file, -1);
+ return;
+ }
+
+ switch(file->org)
+ {
+ case file_line_sequential_e:
+ {
+ file_line_sequential_read(file, data_dest);
+ break;
+ }
+
+ case file_sequential_e:
+ {
+ file_sequential_read(file, data_dest);
+ break;
+ }
+
+ case file_relative_e:
+ {
+ file_relative_read(file, data_dest, next_record);
+ break;
+ }
+
+ case file_indexed_e:
+ {
+ file_indexed_read(file, key, data_dest, next_record);
+ break;
+ }
+
+ default:
+ fprintf(stderr, "%s(): Unhandled cbl_file_org_t %d\n", __func__, file->org);
+ exit(1);
+ break;
+ }
+ }
+
+static void
+file_indexed_open(cblc_file_t *file)
+ {
+ file->p_indexed = new indexed_file_t;
+
+ // We need one multimap for each key. (The first one is the primary key,
+ // but that's just by mutual agreement between the parse and this code.)
+
+ cblc_field_t **keys = file->keys;
+ size_t i=0;
+ while(*keys)
+ {
+ file->p_indexed->indices.push_back(new indexed_file_index);
+ file->p_indexed->indices.back()->the_key = file->keys[i++];
+ keys++;
+ }
+
+ switch( file->mode_char )
+ {
+ case 'w':
+ // OUTPUT mode causes an empty file to be created, so the indices
+ // are empty as well
+ break;
+
+ case 'r':
+ case 'a':
+ case '+':
+ if( file->flags & file_flag_existed_e )
+ {
+ // We need to open the file for reading, and build the
+ // maps for each index:
+ char *fname = internal_to_console(file->filename, strlen(file->filename));
+ FILE *f = fopen(fname, "r");
+ if(f)
+ {
+ size_t record_length = file->record_area_size + 2;
+ unsigned char *record_buffer = (unsigned char *)malloc(record_length);
+ for(;;)
+ {
+ size_t bytes_read;
+ long record_position = ftell(f);
+ if( handle_ferror(file, __func__, "ftell() error") )
+ {
+ goto done;
+ }
+ bytes_read = fread(record_buffer, 1, record_length, f);
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ goto done;
+ }
+ if( bytes_read < record_length )
+ {
+ // Short records aren't allowed, so treat them like
+ // an end-of-file
+ break;
+ }
+ // We have a good read of record_length bytes.
+ // A valid record has a final byte of internal_newline
+ if( record_buffer[record_length-1] == internal_newline )
+ {
+ if( !file_indexed_update_indices(file, record_buffer, record_position) )
+ {
+ // There must have been a duplicate UNIQUE index, or some other problem.
+ goto done;
+ }
+ }
+ else
+ {
+ // This is a hole in the file; make it available for a WRITE or EXTEND
+ file->p_indexed->holes.push_back(record_position);
+ }
+ }
+ // We need to initialize the recent_iterator for every index:
+ for( size_t i=0; i<file->p_indexed->indices.size(); i++ )
+ {
+ file->p_indexed->indices[i]->recent_iterator = file->p_indexed->indices[i]->key_to_position.begin();
+ }
+
+ free(record_buffer);
+ fclose(f);
+ }
+ else
+ {
+ warnx( "%s(): Couldn't open %s for the index read\n",
+ __func__,
+ fname);
+ assert(false);
+ }
+ free(fname);
+ }
+ break;
+
+ default:
+ warnx( "%s(): This is weird. mode_char is '%c' (%d)?\n",
+ __func__,
+ file->mode_char,
+ file->mode_char);
+ assert(false);
+ break;
+ }
+ done:
+ file->p_indexed->recent_index = 0;
+ return;
+ }
+
+static void
+file_indexed_close(cblc_file_t *file)
+ {
+ for(std::vector<indexed_file_index *>::iterator it = file->p_indexed->indices.begin();
+ it != file->p_indexed->indices.end();
+ it++)
+ {
+ delete *it;
+ }
+
+ delete file->p_indexed;
+ file->p_indexed = NULL;
+ }
+
+static void report_open_failure(const char *type,
+ const char *structure_name,
+ const char *filename)
+ {
+ if( getenv(filename) )
+ {
+ fprintf(stderr, "Trying to 'OPEN %s %s %s -> \"%s\"', which doesn't exist\n",
+ type,
+ structure_name,
+ filename,
+ getenv(filename));
+ }
+ else
+ {
+ fprintf(stderr, "Trying to 'OPEN %s %s \"%s\"', which doesn't exist\n",
+ type,
+ structure_name,
+ filename);
+ }
+ }
+
+extern "C"
+void
+__gg__file_open(cblc_file_t *file,
+ int mode_char,
+ int is_quoted)
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+ if( file->file_pointer )
+ {
+ // The file is already open:
+ file->io_status = FsIsOpen; // "41" 14.9.26.3 Paragraph 1
+ }
+ else
+ {
+ // Stash the mode_char for later analysis during READ and WRITE operations
+ file->mode_char = mode_char;
+
+ char *trimmed_name = get_filename(file, is_quoted);
+ if( !trimmed_name )
+ {
+ char *fname = internal_to_console(file->filename, strlen(file->filename));
+ warnx( "%s(): There is no environment variable named %s\n",
+ __func__,
+ fname);
+ file->io_status = FsNoFile; // "35"
+ free(fname);
+ goto done;
+ }
+
+ // achMode is the mode string that gets passed down below to fopen().
+ char achMode[3] = "";
+
+ bool random_access_mode = ( file->access == file_access_rnd_e
+ || file->access == file_access_dyn_e);
+ bool the_file_exists = access(trimmed_name, F_OK) == 0;
+ file->flags |= the_file_exists ? file_flag_existed_e : 0 ;
+
+ // We have four operations: INPUT (r) OUTPUT (w) I-O (+) and EXTEND (a)
+ // INPUT and I-O and EXTEND have different results based on is_optional
+ // and whether or not the file exists.
+ // Various modification take place if random_access_mode is true
+
+ if( the_file_exists )
+ {
+ switch(mode_char)
+ {
+ case 'r':
+ // OPEN INPUT
+ // We need a vanilla read-only file:
+ strcpy(achMode, "r");
+ break;
+
+ case 'w':
+ // OPEN OUTPUT
+ // This syntax means create a new file, or overwrite an existing
+ // one. For files with random access mode, we need to be
+ // able to read as well as write, because we have to be able
+ // to ascertain that a record slot is empty in the event that
+ // the programmer tries to write to the same slot twice:
+ if( random_access_mode )
+ {
+ strcpy(achMode, "w+");
+ }
+ else
+ {
+ strcpy(achMode, "w");
+ }
+ break;
+
+ case 'a':
+ // EXTEND
+ if( random_access_mode )
+ {
+ strcpy(achMode, "r+");
+ }
+ else
+ {
+ // For sequential files, we just do a straight "a"
+ strcpy(achMode, "a");
+ }
+ break;
+
+ case '+':
+ // I-O
+ // We need to be able to read and write the existing file.
+ strcpy(achMode, "r+");
+ break;
+
+ default:
+ fprintf(stderr, "%s(): We were given an unknown mode_char %d\n", __func__, mode_char);
+ exit(1);
+ break;
+ }
+ }
+ else
+ {
+ // The file *doesn't* exist
+ switch(mode_char)
+ {
+ case 'r':
+ // OPEN INPUT, but the file doesn't exist:
+ if( file->flags & file_flag_optional_e )
+ {
+ // This is a weird condition. OPTIONAL means "flag it as sort of open"
+ // but the first read causes AT END or INVALID KEY condition.
+ file->io_status = FsUnavail; // "05"
+ goto done;
+ }
+ else
+ {
+ report_open_failure("INPUT", file->name, trimmed_name);
+ file->io_status = FsNoFile; // "35"
+ goto done;
+ }
+ break;
+
+ case 'w':
+ // OPEN OUTPUT
+ // This syntax means create a new file, or overwrite an existing
+ // one. For files with random access mode, we need to be
+ // able to read as well as write, because we have to be able
+ // to ascertain that a record slot is empty in the event that
+ // the programmer tries to write to the same slot twice:
+ if( random_access_mode )
+ {
+ strcpy(achMode, "w+");
+ }
+ else
+ {
+ strcpy(achMode, "w");
+ }
+ break;
+
+ case 'a':
+ // EXTEND
+ if( file->flags & file_flag_optional_e )
+ {
+ if( random_access_mode )
+ {
+ // For files that might be sequential or random:
+ strcpy(achMode, "a+");
+ }
+ else
+ {
+ // For pure sequential files, we just do a straight "a"
+ strcpy(achMode, "a");
+ }
+ file->io_status = FsUnavail; // "05"
+ }
+ else
+ {
+ // Trying to extend a non-optional non-existing file is against the rules
+ report_open_failure("EXTEND", file->name, trimmed_name);
+ file->io_status = FsNoFile; // "35"
+ goto done;
+ }
+ break;
+
+ case '+':
+ // I-O
+ if( file->flags & file_flag_optional_e )
+ {
+ // We need to be able to read and write a new file.
+ strcpy(achMode, "r+");
+ file->io_status = FsUnavail; // "05"
+ }
+ else
+ {
+ report_open_failure("I-O", file->name, trimmed_name);
+ file->io_status = FsNoFile; // "35"
+ goto done;
+ }
+ break;
+
+ default:
+ fprintf(stderr, "%s(): We were given an unknown mode_char %d\n", __func__, mode_char);
+ exit(1);
+ break;
+ }
+ }
+
+
+ file->file_pointer = fopen(trimmed_name, achMode);
+ free(trimmed_name);
+ if( !file->file_pointer )
+ {
+ __gg__handle_error(__func__, "fopen() failed");
+ goto done;
+ }
+ else
+ {
+ errno = 0;
+ }
+
+ // If this was a OPEN EXTEND, we want the file positioned at the
+ // the very end (which it won't be when achMode is "r+"
+ if( mode_char == 'a' )
+ {
+ fseek(file->file_pointer, 0, SEEK_END);
+ if( handle_ferror(file, __func__, "fseek() after fopen() failed") )
+ {
+ goto done;
+ }
+ }
+ if( file->org == file_indexed_e )
+ {
+ file_indexed_open(file);
+ }
+ }
+ done:
+ establish_status(file, -1);
+ }
+
+extern "C"
+void
+__gg__file_close( cblc_file_t *file )
+ {
+ errno = 0;
+ file->io_status = FsErrno;
+ if( file->file_pointer )
+ {
+ if( fclose(file->file_pointer) )
+ {
+ __gg__handle_error(__func__, "fclose error()");
+ }
+ file->file_pointer = NULL;
+ }
+ else
+ {
+ // Attempting to close a file that isn't open:
+ file->io_status = FsCloseNotOpen; // "42" 14.9.6.3 Paragraph 1
+ }
+
+ if( file->org == file_indexed_e )
+ {
+ file_indexed_close(file);
+ }
+
+ free(file->keys);
+ file->keys = NULL;
+ free(file->uniques);
+ file->uniques = NULL;
+
+ // Free any memory allocated in parser_file_open
+ free(file->filename);
+ file->filename = NULL;
+
+ establish_status(file, -1);
+ }
+
+
+
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
new file mode 100644
index 000000000000..ab02538e6ace
--- /dev/null
+++ b/libgcobol/gmath.cc
@@ -0,0 +1,773 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (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 <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 <algorithm>
+
+#include "libgcobol.h"
+#include "gmath.h"
+
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+
+static int
+conditional_stash( cblc_refer_t *destination,
+ bool on_error_flag,
+ __int128 value,
+ int rdigits,
+ rounded_t rounded)
+ {
+ int retval = 0;
+ if( !on_error_flag )
+ {
+ // It's an uncomplicated assignment, because there was no
+ // ON SIZE ERROR phrase
+ __gg__scale_to_refer( destination,
+ value,
+ rdigits,
+ rounded,
+ NULL);
+ }
+ else
+ {
+ // This is slightly more complex, because in the event of a
+ // SIZE ERROR. we need to leave the original value untouched
+
+ cblc_resolved_t target;
+ __gg__refer_resolve(destination, &target);
+
+ unsigned char *stash = (unsigned char *)malloc(target.length_untrimmed);
+ memcpy(stash, target.location, target.length_untrimmed);
+ bool s_error;
+ __gg__scale_to_resolved( &target,
+ value,
+ rdigits,
+ rounded,
+ &s_error);
+ if( s_error )
+ {
+ retval = 1;
+ // Because there was a size error, we will report that
+ // upon return, and we need to put back the original value:
+ memcpy(target.location, stash, target.length_untrimmed);
+ }
+ free(stash);
+ }
+ return retval;
+ }
+
+extern "C"
+int
+__gg__add( cbl_arith_format_t format,
+ size_t nA,
+ size_t ,
+ size_t nC,
+ cblc_refer_t *A,
+ cblc_refer_t *,
+ cblc_refer_t *C,
+ rounded_t *rounded,
+ int on_error_flag)
+ {
+ int size_error = 0; // This is the return value
+
+ switch(format)
+ {
+ case no_giving_e:
+ {
+ // There was no GIVING phrase, so this is a FORMAT 1 ADD
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ int running_rdigits;
+ __int128 running_sum;
+ for(size_t i=0; i<nC; i++)
+ {
+ // For each Ci, we add up all of A[], and then accumulate that into Ci
+ // We do this repeatedly because it's possible that an element of C
+ // can be an element of A.
+
+ running_sum = 0;
+ running_rdigits = 0;
+
+ for(size_t j=0; j<nA; j++)
+ {
+ // Pick up the next value from the A[] list
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &A[j]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or running_rdigits
+ if( running_rdigits > rdigits )
+ {
+ // Scale th3e latest value to the running one:
+ value *= __gg__power_of_ten(running_rdigits-rdigits);
+ }
+ else if( rdigits > running_rdigits )
+ {
+ // Update running_sum to match the latest value
+ running_sum *= __gg__power_of_ten(rdigits-running_rdigits);
+ running_rdigits = rdigits;
+ }
+ // At this point, running_sum and value have the same rdigits:
+ running_sum += value;
+ }
+
+ // We have used up the A[] list. We now accumulate target into
+ // the running_sum:
+
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &C[i]);
+ if( running_rdigits > rdigits )
+ {
+ value *= __gg__power_of_ten(running_rdigits-rdigits);
+ }
+ else if( rdigits > running_rdigits )
+ {
+ running_sum *= __gg__power_of_ten(rdigits-running_rdigits);
+ running_rdigits = rdigits;
+ }
+ running_sum += value;
+
+ // At this point, we assign running_sum to *C.
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ running_sum,
+ running_rdigits,
+ *rounded++);
+ }
+ break;
+ }
+
+ case giving_e:
+ {
+ // There was a GIVING phrase, so this is a FORMAT 2 ADD
+
+ // We will add up the list of A[] values, add in the single B[]
+ // value, and place that result into all of the C[] values
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ int digits_of_a = 0;
+ __int128 sum_of_a = 0;
+
+ // Add in all of the A[] values:
+ for(size_t i=0; i<nA; i++)
+ {
+ // Pick up the next value from the A[] list
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &A[i]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or digits_of_a
+ if( digits_of_a > rdigits )
+ {
+ // Scale the latest value to the running one:
+ value *= __gg__power_of_ten(digits_of_a-rdigits);
+ }
+ else if( rdigits > digits_of_a )
+ {
+ // Update running_sum to match the latest value
+ sum_of_a *= __gg__power_of_ten(rdigits-digits_of_a);
+ digits_of_a = rdigits;
+ }
+ // At this point, running_sum and value have the same rdigits:
+ sum_of_a += value;
+ }
+
+ // The sum is now place into every element of the C[] list:
+ for(size_t i=0; i<nC; i++)
+ {
+ // At this point, we assign sum_of_a to *C.
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ sum_of_a,
+ digits_of_a,
+ *rounded++);
+ }
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // This is a FORMAT 3 ADD CORRESPONDING
+ int hyphen;
+
+ __int128 c_value;
+ int c_digits;
+
+ __int128 a_value;
+ int a_digits;
+ for(size_t i=0; i<nC; i++)
+ {
+ // We accumulate each Ai into Ci
+
+ c_value = __gg__binary_value_from_refer(&hyphen, &c_digits, &C[i]);
+ a_value = __gg__binary_value_from_refer(&hyphen, &a_digits, &A[i]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or running_rdigits
+ if( c_digits > a_digits )
+ {
+ a_value *= __gg__power_of_ten(c_digits - a_digits);
+ }
+ else if( a_digits > c_digits )
+ {
+ // Update c_value to match the latest value
+ c_value *= __gg__power_of_ten(a_digits-c_digits);
+ c_digits = a_digits;
+ }
+
+ // At this point, c_value and value have the same rdigits:
+ c_value += a_value;
+
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ c_value,
+ c_digits,
+ *rounded++);
+ }
+ break;
+ }
+
+ case not_expected_e:
+ assert(false);
+ break;
+ }
+
+ return size_error ? 1 : 0;
+ }
+
+extern "C"
+int
+__gg__subtract( cbl_arith_format_t format,
+ size_t nA,
+ size_t ,
+ size_t nC,
+ cblc_refer_t *A,
+ cblc_refer_t *B,
+ cblc_refer_t *C,
+ rounded_t *rounded,
+ int on_error_flag)
+ {
+ int size_error = 0; // This is the return value
+
+ switch(format)
+ {
+ case no_giving_e:
+ {
+ // There was no GIVING phrase, so this is a FORMAT 1 SUBTRACT
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ int running_rdigits;
+ __int128 running_sum;
+ for(size_t i=0; i<nC; i++)
+ {
+ // For each Ci, we add up all of A[], and then accumulate that into Ci
+ // We do this repeatedly because it's possible that an element of C
+ // can be an element of A.
+
+ // Initialize running_sum
+ running_sum = 0;
+ running_rdigits = 0;
+
+ for(size_t j=0; j<nA; j++)
+ {
+ // Pick up the next value from the A[] list
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &A[j]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or running_rdigits
+ if( running_rdigits > rdigits )
+ {
+ // Scale the latest value to the running one:
+ value *= __gg__power_of_ten(running_rdigits-rdigits);
+ }
+ else if( rdigits > running_rdigits )
+ {
+ // Update running_sum to match the latest value
+ running_sum *= __gg__power_of_ten(rdigits-running_rdigits);
+ running_rdigits = rdigits;
+ }
+ // At this point, running_sum and value have the same rdigits:
+ running_sum += value;
+ }
+
+ // We have used up the A[] list. We now subtract that from
+ // the target value
+
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &C[i]);
+ if( running_rdigits > rdigits )
+ {
+ value *= __gg__power_of_ten(running_rdigits-rdigits);
+ }
+ else if( rdigits > running_rdigits )
+ {
+ running_sum *= __gg__power_of_ten(rdigits-running_rdigits);
+ running_rdigits = rdigits;
+ }
+
+ value -= running_sum;
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ value,
+ running_rdigits,
+ *rounded++);
+ }
+ break;
+ }
+
+ case giving_e:
+ {
+ // There was a GIVING phrase, so this is a FORMAT 2 SUBTRACT
+
+ // We will add up the list of A[] values, subtract that from the single B[]
+ // value, and place that result into all of the C[] values
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ int digits_of_a = 0;
+ __int128 sum_of_a = 0;
+
+ // Add in all of the A[] values:
+ for(size_t i=0; i<nA; i++)
+ {
+ // Pick up the next value from the A[] list
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &A[i]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or digits_of_a
+ if( digits_of_a > rdigits )
+ {
+ // Scale the latest value to the running one:
+ value *= __gg__power_of_ten(digits_of_a-rdigits);
+ }
+ else if( rdigits > digits_of_a )
+ {
+ // Update running_sum to match the latest value
+ sum_of_a *= __gg__power_of_ten(rdigits-digits_of_a);
+ digits_of_a = rdigits;
+ }
+ // At this point, running_sum and value have the same rdigits:
+ sum_of_a += value;
+ }
+
+ // We know there is but one B[] value:
+
+ value = __gg__binary_value_from_refer(&hyphen, &rdigits, &B[0]);
+
+ if( digits_of_a > rdigits )
+ {
+ // Scale the latest value to the running one:
+ value *= __gg__power_of_ten(digits_of_a-rdigits);
+ }
+ else if( rdigits > digits_of_a )
+ {
+ // Update running_sum to match the latest value
+ sum_of_a *= __gg__power_of_ten(rdigits-digits_of_a);
+ digits_of_a = rdigits;
+ }
+
+ value -= sum_of_a;
+
+ // The running sum is now placed into every element of the C[] list:
+ for(size_t i=0; i<nC; i++)
+ {
+ // At this point, we assign value to *C.
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ value,
+ digits_of_a,
+ *rounded++);
+ }
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // This is a FORMAT 3 ADD CORRESPONDING
+ int hyphen;
+
+ __int128 c_value;
+ int c_digits;
+
+ __int128 a_value;
+ int a_digits;
+ for(size_t i=0; i<nC; i++)
+ {
+ // We accumulate each Ai into Ci
+ c_value = __gg__binary_value_from_refer(&hyphen, &c_digits, &C[i]);
+ a_value = __gg__binary_value_from_refer(&hyphen, &a_digits, &A[i]);
+
+ // Adjust one or the other, as necessary, to accommodate the
+ // larger of rdigits or running_rdigits
+ if( c_digits > a_digits )
+ {
+ a_value *= __gg__power_of_ten(c_digits - a_digits);
+ }
+ else if( a_digits > c_digits )
+ {
+ // Update c_value to match the latest value
+ c_value *= __gg__power_of_ten(a_digits-c_digits);
+ c_digits = a_digits;
+ }
+
+ // At this point, c_value and value have the same rdigits:
+ c_value -= a_value;
+
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ c_value,
+ c_digits,
+ *rounded++);
+ }
+ break;
+ }
+
+ case not_expected_e:
+ assert(false);
+ break;
+ }
+
+ return size_error ? 1 : 0;
+ }
+
+extern "C"
+int
+__gg__multiply( cbl_arith_format_t /*format*/,
+ size_t ,
+ size_t nB,
+ size_t nC,
+ cblc_refer_t *A,
+ cblc_refer_t *B,
+ cblc_refer_t *C,
+ rounded_t *rounded,
+ int on_error_flag)
+ {
+ int size_error = 0; // This is the return value
+ if( nB == 0 )
+ {
+ // There was no GIVING phrase, so this is a FORMAT 1 MULTIPLY
+ int hyphen;
+ int rdigits;
+ int product_rdigits;
+
+ __int128 a_value;
+ __int128 b_value;
+ __int128 product;
+
+ for(size_t i=0; i<nC; i++)
+ {
+ // There is only one A[] value. Each value of C gets multiplied
+ // by that A value, and the result placed in C. Lather, rinse, repeat.
+ // We pick up the A value each time, because that A value can appear
+ // in the list of C.
+
+ a_value = __gg__binary_value_from_refer(&hyphen, &product_rdigits, &A[0]);
+ b_value = __gg__binary_value_from_refer(&hyphen, &rdigits, &C[i]);
+ product = a_value * b_value;
+ product_rdigits += rdigits;
+
+ // At this point, we assign the product to *C.
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ product,
+ product_rdigits,
+ *rounded++);
+ }
+ }
+ else
+ {
+ // There was a GIVING phrase, so this is a FORMAT 2 MULTIPLY
+
+ // There is a single A value and a single B value. Their product is
+ // placed into all of the C values.
+
+ int hyphen;
+ int rdigits;
+ int product_rdigits;
+
+ __int128 a_value;
+ __int128 b_value;
+ __int128 product;
+
+ a_value = __gg__binary_value_from_refer(&hyphen, &product_rdigits, &A[0]);
+ b_value = __gg__binary_value_from_refer(&hyphen, &rdigits, &B[0]);
+ product = a_value * b_value;
+ product_rdigits += rdigits;
+
+ for(size_t i=0; i<nC; i++)
+ {
+ // There is only one A[] value. Each value of C gets multiplied
+ // by that A value, and the result placed in C. Lather, rinse, repeat.
+ // We pick up the A value each time, because that A value can appear
+ // in the list of C.
+
+ size_error |= conditional_stash(&C[i],
+ on_error_flag,
+ product,
+ product_rdigits,
+ *rounded++);
+ }
+ }
+
+ return size_error ? 1 : 0;
+ }
+
+static
+__int128
+divide_helper( __int128 a_value,
+ int a_decimals,
+ __int128 b_value,
+ int b_decimals,
+ int target_decimals,
+ rounded_t rounded)
+ {
+ // We calculate a / b
+
+ // We were given, for example, a_value = 12 and a_decimals = 1
+ // convert that to a = 1.19999999999999999999999999999999996
+ __float128 a = (__float128)a_value;
+ a /= __gg__power_of_ten(a_decimals);
+
+ // Likewise, we might have been given b = 300 and b_decimals = 2
+ // convert that to b = 3.0000
+ __float128 b = (__float128)b_value;
+ b /= __gg__power_of_ten(b_decimals);
+
+ // Do the actual division, giving us 0.399999999999999999999999999999999971
+ a /= b;
+
+ // Multiply by the target decimals, giving us 3.99999999999999999999999999999999961
+ a *= __gg__power_of_ten(target_decimals);
+
+ // We are going to convert that to an (__int128), which results in the
+ // unwanted 3. To handle the floating point problem of numbers being a
+ // wee bit too small, we are going to add 0.05 to the result, in this
+ // case yielding 4.05000000000000000277555756156289135
+
+ if( a < 0 )
+ {
+ a -= (__float128)0.05;
+ }
+ else
+ {
+ a += (__float128)0.05;
+ }
+
+ // And now we handle the user's desire, if any, to round to the integer place
+
+ if( rounded == rounded_e )
+ {
+ if( a < 0.0 )
+ {
+ a -= 0.5;
+ }
+ else
+ {
+ a += 0.5;
+ }
+ }
+
+ return (__int128)a;
+ }
+
+#define ON_SIZE_ERROR 0x01
+#define REMAINDER_PRESENT 0x02
+
+extern "C"
+int
+__gg__divide( cbl_arith_format_t /*format*/,
+ size_t ,
+ size_t nB,
+ size_t nC,
+ cblc_refer_t *A,
+ cblc_refer_t *B,
+ cblc_refer_t *C,
+ rounded_t *rounded,
+ int flags) // 0x01 check for size error 0x02 remainder is present
+ {
+ int size_error = 0; // This is the return value
+ if( nB == 0 )
+ {
+ // There was no GIVING phrase, so this is a FORMAT 1 DIVISION
+ int hyphen;
+ int a_decimals;
+ int b_decimals;
+
+ __int128 a_value;
+ __int128 b_value;
+ __int128 quotient;
+
+ for(size_t i=0; i<nC; i++)
+ {
+ // There is only one A[] value, which gets divided into each
+ // value of C[]. The result will be placed in C provided there
+ // is no SIZE ERROR. We repeat the entire operation for each
+ // value of C, picking up A each time because an element of A can
+ // also appear as an element of C
+ a_value = __gg__binary_value_from_refer(&hyphen, &a_decimals, &A[0]);
+ b_value = __gg__binary_value_from_refer(&hyphen, &b_decimals, &C[i]);
+
+ if( (C[i].field->attr & intermediate_e) && b_value != 0 )
+ {
+ // This is an intermediate calculation value, so we want to
+ // boost b_decimals to be as big as we can make it:
+ while( b_value < (((__int128)1) << 126) && b_decimals < 13)
+ {
+ b_value *= 10;
+ b_decimals += 1;
+ }
+ }
+
+ // Do the b divided by a thing:
+ quotient = divide_helper(b_value, b_decimals, a_value, a_decimals, b_decimals, rounded[i]);
+
+ // At this point, we assign running_sum to *C.
+ size_error |= conditional_stash(&C[i],
+ (flags & ON_SIZE_ERROR),
+ quotient,
+ b_decimals,
+ rounded[i]);
+ }
+ }
+ else
+ {
+ // There was a GIVING phrase, so this is a FORMAT 2 MULTIPLY
+
+ // There is a single A value and a single B value. Their quotient is
+ // placed into all of the C values.
+
+ // When the REMAINDER bit is on, the REMAINDER is the first element of
+ // the C[] array, and the quotient is the second.
+
+ int hyphen;
+ int a_decimals;
+ int b_decimals;
+ int c_decimals;
+
+ __int128 a_value;
+ __int128 b_value;
+ __int128 quotient;
+ __int128 remainder;
+
+ a_value = __gg__binary_value_from_refer(&hyphen, &a_decimals, &A[0]);
+ b_value = __gg__binary_value_from_refer(&hyphen, &b_decimals, &B[0]);
+
+ for(size_t i=0; i<nC; i++)
+ {
+ if( (flags & REMAINDER_PRESENT) && i == 0 )
+ {
+ // There is a remainder at the beginning of C[]; skip over it
+ continue;
+ }
+ c_decimals = C[i].field->rdigits;
+ if(c_decimals < 0)
+ {
+ c_decimals = 0;
+ }
+
+ if( (C[i].field->attr & intermediate_e) && a_value != 0 )
+ {
+ // This is an intermediate calculation value, so we want to
+ // boost b_decimals to be as big as we can make it:
+ while( a_value < (((__int128)1) << 126) && a_decimals < 13)
+ {
+ a_value *= 10;
+ a_decimals += 1;
+ }
+ c_decimals = a_decimals;
+ }
+
+ __int128 unrounded_quotient = divide_helper(a_value, a_decimals, b_value, b_decimals, c_decimals, unrounded_e);
+ quotient = divide_helper(a_value, a_decimals, b_value, b_decimals, c_decimals, rounded[i]);
+ size_error |= conditional_stash(&C[i],
+ (flags & ON_SIZE_ERROR),
+ quotient,
+ c_decimals,
+ rounded[i]);
+
+ if( !size_error && (flags & REMAINDER_PRESENT) )
+ {
+ // We need to calculate the remainder
+
+ // Remainders in COBOL are seriously weird. The NIST suite
+ // has an example where 174 is divided by 16. The quotient
+ // is a 999.9, and the remainder is a 9999
+
+ // So, here goes: 174 by 16 is 10.875. The unrounded
+ // assignment to Q is thus 10.8
+ // You then multiply 10.8 by 16, giving 172.8
+ // That gets subtracted from 174, giving 1.2
+ // That gets assigned to the 9999 remainder, which is
+ // thus 1
+
+ // Any mathematician would walk away, slowly, shaking their head.
+
+ // We need to multiply the unrounded quotient by b_value. We'll use 'quotient' as
+ // a working variable:
+ unrounded_quotient *= b_value;
+ c_decimals += b_decimals;
+
+ // We need to subtract quotient from a_value:
+
+ if( c_decimals > a_decimals )
+ {
+ a_value *= __gg__power_of_ten(c_decimals-a_decimals);
+ a_decimals = c_decimals;
+ }
+ else if( a_decimals > c_decimals)
+ {
+ unrounded_quotient *= __gg__power_of_ten(a_decimals-c_decimals);
+ c_decimals = a_decimals;
+ }
+
+ remainder = a_value - unrounded_quotient;
+ size_error |= conditional_stash(&C[0],
+ (flags & ON_SIZE_ERROR),
+ remainder,
+ c_decimals,
+ unrounded_e);
+ }
+ }
+ }
+
+ return size_error ? 1 : 0;
+ }
diff --git a/libgcobol/hash.c b/libgcobol/hash.c
deleted file mode 100644
index ec0d91a9c962..000000000000
--- a/libgcobol/hash.c
+++ /dev/null
@@ -1,294 +0,0 @@
-/* Hash tables for Objective C internal structures
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include <assert.h> /* For assert. */
-
-#include "objc/runtime.h" /* For objc_calloc. */
-#include "objc-private/hash.h"
-
-/* These two macros determine when a hash table is full and
- by how much it should be expanded respectively.
-
- These equations are percentages. */
-#define FULLNESS(cache) \
- ((((cache)->size * 75) / 100) <= (cache)->used)
-#define EXPANSION(cache) \
- ((cache)->size * 2)
-
-cache_ptr
-objc_hash_new (unsigned int size, hash_func_type hash_func,
- compare_func_type compare_func)
-{
- cache_ptr cache;
-
- /* Pass me a value greater than 0 and a power of 2. */
- assert (size);
- assert (! (size & (size - 1)));
-
- /* Allocate the cache structure. calloc insures its initialization
- for default values. */
- cache = (cache_ptr) objc_calloc (1, sizeof (struct cache));
- assert (cache);
-
- /* Allocate the array of buckets for the cache. calloc initializes
- all of the pointers to NULL. */
- cache->node_table
- = (node_ptr *) objc_calloc (size, sizeof (node_ptr));
- assert (cache->node_table);
-
- cache->size = size;
-
- /* This should work for all processor architectures (?). */
- cache->mask = (size - 1);
-
- /* Store the hashing function so that codes can be computed. */
- cache->hash_func = hash_func;
-
- /* Store the function that compares hash keys to determine if they
- are equal. */
- cache->compare_func = compare_func;
-
- return cache;
-}
-
-
-void
-objc_hash_delete (cache_ptr cache)
-{
- node_ptr node;
- node_ptr next_node;
- unsigned int i;
-
- /* Purge all key/value pairs from the table. */
- /* Step through the nodes one by one and remove every node WITHOUT
- using objc_hash_next. this makes objc_hash_delete much more
- efficient. */
- for (i = 0; i < cache->size; i++)
- {
- if ((node = cache->node_table[i]))
- {
- /* An entry in the hash table has been found. Now step
- through the nodes next in the list and free them. */
- while ((next_node = node->next))
- {
- objc_hash_remove (cache,node->key);
- node = next_node;
- }
- objc_hash_remove (cache,node->key);
- }
- }
-
- /* Release the array of nodes and the cache itself. */
- objc_free(cache->node_table);
- objc_free(cache);
-}
-
-
-void
-objc_hash_add (cache_ptr *cachep, const void *key, void *value)
-{
- size_t indx = (*(*cachep)->hash_func) (*cachep, key);
- node_ptr node = (node_ptr) objc_calloc (1, sizeof (struct cache_node));
-
- assert (node);
-
- /* Initialize the new node. */
- node->key = key;
- node->value = value;
- node->next = (*cachep)->node_table[indx];
-
- /* Debugging. Check the list for another key. */
-#ifdef DEBUG
- {
- node_ptr node1 = (*cachep)->node_table[indx];
- while (node1)
- {
- assert (node1->key != key);
- node1 = node1->next;
- }
- }
-#endif
-
- /* Install the node as the first element on the list. */
- (*cachep)->node_table[indx] = node;
-
- /* Bump the number of entries in the cache. */
- ++(*cachep)->used;
-
- /* Check the hash table's fullness. We're going to expand if it is
- above the fullness level. */
- if (FULLNESS (*cachep))
- {
- /* The hash table has reached its fullness level. Time to
- expand it.
-
- I'm using a slow method here but is built on other primitive
- functions thereby increasing its correctness. */
- node_ptr node1 = NULL;
- cache_ptr new = objc_hash_new (EXPANSION (*cachep),
- (*cachep)->hash_func,
- (*cachep)->compare_func);
-
- DEBUG_PRINTF ("Expanding cache %#x from %d to %d\n",
- (int) *cachep, (*cachep)->size, new->size);
-
- /* Copy the nodes from the first hash table to the new one. */
- while ((node1 = objc_hash_next (*cachep, node1)))
- objc_hash_add (&new, node1->key, node1->value);
-
- /* Trash the old cache. */
- objc_hash_delete (*cachep);
-
- /* Return a pointer to the new hash table. */
- *cachep = new;
- }
-}
-
-void
-objc_hash_remove (cache_ptr cache, const void *key)
-{
- size_t indx = (*cache->hash_func) (cache, key);
- node_ptr node = cache->node_table[indx];
-
- /* We assume there is an entry in the table. Error if it is
- not. */
- assert (node);
-
- /* Special case. First element is the key/value pair to be
- removed. */
- if ((*cache->compare_func) (node->key, key))
- {
- cache->node_table[indx] = node->next;
- objc_free(node);
- }
- else
- {
- /* Otherwise, find the hash entry. */
- node_ptr prev = node;
- BOOL removed = NO;
- do
- {
- if ((*cache->compare_func) (node->key, key))
- {
- prev->next = node->next, removed = YES;
- objc_free(node);
- }
- else
- prev = node, node = node->next;
- }
- while (!removed && node);
- assert (removed);
- }
-
- /* Decrement the number of entries in the hash table. */
- --cache->used;
-}
-
-
-node_ptr
-objc_hash_next (cache_ptr cache, node_ptr node)
-{
- /* If the scan is being started then reset the last node visitied
- pointer and bucket index. */
- if (!node)
- cache->last_bucket = 0;
-
- /* If there is a node visited last then check for another entry in
- the same bucket. Otherwise step to the next bucket. */
- if (node)
- {
- if (node->next)
- {
- /* There is a node which follows the last node returned.
- Step to that node and retun it. */
- return node->next;
- }
- else
- ++cache->last_bucket;
- }
-
- /* If the list isn't exhausted then search the buckets for other
- nodes. */
- if (cache->last_bucket < cache->size)
- {
- /* Scan the remainder of the buckets looking for an entry at
- the head of the list. Return the first item found. */
- while (cache->last_bucket < cache->size)
- if (cache->node_table[cache->last_bucket])
- return cache->node_table[cache->last_bucket];
- else
- ++cache->last_bucket;
-
- /* No further nodes were found in the hash table. */
- return NULL;
- }
- else
- return NULL;
-}
-
-
-/* Given KEY, return corresponding value for it in CACHE. Return NULL
- if the KEY is not recorded. */
-void *
-objc_hash_value_for_key (cache_ptr cache, const void *key)
-{
- node_ptr node = cache->node_table[(*cache->hash_func) (cache, key)];
- void *retval = NULL;
-
- if (node)
- do
- {
- if ((*cache->compare_func) (node->key, key))
- {
- retval = node->value;
- break;
- }
- else
- node = node->next;
- }
- while (! retval && node);
-
- return retval;
-}
-
-/* Given KEY, return YES if it exists in the CACHE. Return NO if it
- does not */
-BOOL
-objc_hash_is_key_in_hash (cache_ptr cache, const void *key)
-{
- node_ptr node = cache->node_table[(*cache->hash_func) (cache, key)];
-
- if (node)
- do
- {
- if ((*cache->compare_func)(node->key, key))
- return YES;
- else
- node = node->next;
- }
- while (node);
-
- return NO;
-}
diff --git a/libgcobol/init.c b/libgcobol/init.c
deleted file mode 100644
index 3f890ff4cfd9..000000000000
--- a/libgcobol/init.c
+++ /dev/null
@@ -1,1043 +0,0 @@
-/* GNU Objective C Runtime initialization
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
- +load support contributed by Ovidiu Predescu <ovidiu@net-community.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* Uncommented the following line to enable debug logging. Use this
- only while debugging the runtime. */
-/* #define DEBUG 1 */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-#include "objc/runtime.h"
-#include "objc/thr.h"
-#include "objc-private/hash.h"
-#include "objc-private/objc-list.h"
-#include "objc-private/module-abi-8.h"
-#include "objc-private/runtime.h" /* For __objc_resolve_class_links(). */
-#include "objc-private/selector.h" /* For __sel_register_typed_name(). */
-#include "objc-private/objc-sync.h" /* For __objc_sync_init() */
-#include "objc-private/protocols.h" /* For __objc_protocols_init(),
- __objc_protocols_add_protocol()
- __objc_protocols_register_selectors() */
-#include "objc-private/accessors.h" /* For __objc_accessors_init() */
-
-/* The version number of this runtime. This must match the number
- defined in gcc (objc-act.c). */
-#define OBJC_VERSION 8
-#define PROTOCOL_VERSION 2
-
-/* This list contains modules currently loaded into the runtime and
- for which the +load method (and the load callback, if any) has not
- been called yet. */
-static struct objc_list *__objc_module_list = 0; /* !T:MUTEX */
-
-/* This list contains all proto_list's not yet assigned class
- links. */
-static struct objc_list *unclaimed_proto_list = 0; /* !T:MUTEX */
-
-/* List of unresolved static instances. */
-static struct objc_list *uninitialized_statics = 0; /* !T:MUTEX */
-
-/* List of duplicated classes found while loading modules. If we find
- a class twice, we ignore it the second time. On some platforms,
- where the order in which modules are loaded is well defined, this
- allows you to replace a class in a shared library by linking in a
- new implementation which is loaded in in the right order, and which
- overrides the existing one.
-
- Protected by __objc_runtime_mutex. */
-static cache_ptr duplicate_classes = NULL;
-
-/* Global runtime "write" mutex. Having a single mutex prevents
- deadlocks, but reduces concurrency. To improve concurrency, some
- groups of functions in the runtime have their own separate mutex
- (eg, __class_table_lock in class.c); to avoid deadlocks, these
- routines must make sure that they never acquire any other lock
- while holding their own local lock. Ie, they should lock, execute
- some C code that does not perform any calls to other runtime
- functions which may potentially lock different locks, then unlock.
- If they need to perform any calls to other runtime functions that
- may potentially lock other locks, then they should use the global
- __objc_runtime_mutex. */
-objc_mutex_t __objc_runtime_mutex = 0;
-
-/* Number of threads that are alive. */
-int __objc_runtime_threads_alive = 1; /* !T:MUTEX */
-
-/* Check compiler vs runtime version. */
-static void init_check_module_version (struct objc_module *);
-
-/* Assign isa links to protos. */
-static void __objc_init_protocols (struct objc_protocol_list *protos);
-
-/* Assign isa link to a protocol, and register it. */
-static void __objc_init_protocol (struct objc_protocol *protocol);
-
-/* Add protocol to class. */
-static void __objc_class_add_protocols (Class, struct objc_protocol_list *);
-
-/* Load callback hook. */
-void (*_objc_load_callback) (Class class, struct objc_category *category) = 0; /* !T:SAFE */
-
-/* Are all categories/classes resolved ? */
-BOOL __objc_dangling_categories = NO; /* !T:UNUSED */
-
-/* Sends +load to all classes and categories in certain
- situations. */
-static void objc_send_load (void);
-
-/* Inserts all the classes defined in module in a tree of classes that
- resembles the class hierarchy. This tree is traversed in preorder
- and the classes in its nodes receive the +load message if these
- methods were not executed before. The algorithm ensures that when
- the +load method of a class is executed all the superclasses have
- been already received the +load message. */
-static void __objc_create_classes_tree (struct objc_module *module);
-
-/* Calls the _objc_load_callback for each class and category in the
- module (if _objc_load_callback is not NULL). */
-static void __objc_call_load_callback (struct objc_module *module);
-
-/* A special version that works only before the classes are completely
- installed in the runtime. */
-static BOOL class_is_subclass_of_class (Class class, Class superclass);
-
-/* This is a node in the class tree hierarchy used to send +load
- messages. */
-typedef struct objc_class_tree
-{
- /* The class corresponding to the node. */
- Class class;
-
- /* This is a linked list of all the direct subclasses of this class.
- 'head' points to a subclass node; 'tail' points to the next
- objc_list node (whose 'head' points to another subclass node,
- etc). */
- struct objc_list *subclasses;
-} objc_class_tree;
-
-/* This is a linked list of objc_class_tree trees. The head of these
- trees are root classes (their super class is Nil). These different
- trees represent different class hierarchies. */
-static struct objc_list *__objc_class_tree_list = NULL;
-
-/* Keeps the +load methods who have been already executed. This hash
- should not be destroyed during the execution of the program. */
-static cache_ptr __objc_load_methods = NULL;
-
-/* This function is used when building the class tree used to send
- ordinately the +load message to all classes needing it. The tree
- is really needed so that superclasses will get the message before
- subclasses.
-
- This tree may contain classes which are being loaded (or have just
- being loaded), and whose super_class pointers have not yet been
- resolved. This implies that their super_class pointers point to a
- string with the name of the superclass; when the first message is
- sent to the class (/an object of that class) the class links will
- be resolved, which will replace the super_class pointers with
- pointers to the actual superclasses.
-
- Unfortunately, the tree might also contain classes which had been
- loaded previously, and whose class links have already been
- resolved.
-
- This function returns the superclass of a class in both cases, and
- can be used to build the determine the class relationships while
- building the tree. */
-static Class class_superclass_of_class (Class class)
-{
- char *super_class_name;
-
- /* If the class links have been resolved, use the resolved
- links. */
- if (CLS_ISRESOLV (class))
- return class->super_class;
-
- /* Else, 'class' has not yet been resolved. This means that its
- super_class pointer is really the name of the super class (rather
- than a pointer to the actual superclass). */
- super_class_name = (char *)class->super_class;
-
- /* Return Nil for a root class. */
- if (super_class_name == NULL)
- return Nil;
-
- /* Lookup the superclass of non-root classes. */
- return objc_getClass (super_class_name);
-}
-
-
-/* Creates a tree of classes whose topmost class is directly inherited
- from `upper' and the bottom class in this tree is `bottom_class'.
- If `upper' is Nil, creates a class hierarchy up to a root class.
- The classes in this tree are super classes of `bottom_class'. The
- `subclasses' member of each tree node point to the list of
- subclasses for the node. */
-static objc_class_tree *
-create_tree_of_subclasses_inherited_from (Class bottom_class, Class upper)
-{
- Class superclass;
- objc_class_tree *tree, *prev;
-
- DEBUG_PRINTF ("create_tree_of_subclasses_inherited_from:");
- DEBUG_PRINTF (" bottom_class = %s, upper = %s\n",
- (bottom_class ? bottom_class->name : NULL),
- (upper ? upper->name : NULL));
-
- superclass = class_superclass_of_class (bottom_class);
-
- prev = objc_calloc (1, sizeof (objc_class_tree));
- prev->class = bottom_class;
-
- if (superclass == upper)
- return prev;
-
- while (superclass != upper)
- {
- tree = objc_calloc (1, sizeof (objc_class_tree));
- tree->class = superclass;
- tree->subclasses = list_cons (prev, tree->subclasses);
- superclass = class_superclass_of_class (superclass);
- prev = tree;
- }
-
- return tree;
-}
-
-/* Insert the `class' into the proper place in the `tree' class
- hierarchy. This function returns a new tree if the class has been
- successfully inserted into the tree or NULL if the class is not
- part of the classes hierarchy described by `tree'. This function
- is private to objc_tree_insert_class (), you should not call it
- directly. */
-static objc_class_tree *
-__objc_tree_insert_class (objc_class_tree *tree, Class class)
-{
- DEBUG_PRINTF ("__objc_tree_insert_class: tree = %p (root: %s), class = %s\n",
- tree, ((tree && tree->class) ? tree->class->name : "Nil"), class->name);
-
- if (tree == NULL)
- return create_tree_of_subclasses_inherited_from (class, NULL);
- else if (class == tree->class)
- {
- /* `class' has been already inserted. */
- DEBUG_PRINTF (" 1. class %s was previously inserted\n", class->name);
- return tree;
- }
- else if (class_superclass_of_class (class) == tree->class)
- {
- /* If class is a direct subclass of tree->class then add class
- to the list of subclasses. First check to see if it wasn't
- already inserted. */
- struct objc_list *list = tree->subclasses;
- objc_class_tree *node;
-
- while (list)
- {
- /* Class has been already inserted; do nothing just return
- the tree. */
- if (((objc_class_tree *) list->head)->class == class)
- {
- DEBUG_PRINTF (" 2. class %s was previously inserted\n",
- class->name);
- return tree;
- }
- list = list->tail;
- }
-
- /* Create a new node class and insert it into the list of
- subclasses. */
- node = objc_calloc (1, sizeof (objc_class_tree));
- node->class = class;
- tree->subclasses = list_cons (node, tree->subclasses);
- DEBUG_PRINTF (" 3. class %s inserted\n", class->name);
- return tree;
- }
- else
- {
- /* The class is not a direct subclass of tree->class. Search
- for class's superclasses in the list of subclasses. */
- struct objc_list *subclasses = tree->subclasses;
-
- /* Precondition: the class must be a subclass of tree->class;
- otherwise return NULL to indicate our caller that it must
- take the next tree. */
- if (! class_is_subclass_of_class (class, tree->class))
- return NULL;
-
- for (; subclasses != NULL; subclasses = subclasses->tail)
- {
- Class aClass = ((objc_class_tree *) (subclasses->head))->class;
-
- if (class_is_subclass_of_class (class, aClass))
- {
- /* If we found one of class's superclasses we insert the
- class into its subtree and return the original tree
- since nothing has been changed. */
- subclasses->head
- = __objc_tree_insert_class (subclasses->head, class);
- DEBUG_PRINTF (" 4. class %s inserted\n", class->name);
- return tree;
- }
- }
-
- /* We haven't found a subclass of `class' in the `subclasses'
- list. Create a new tree of classes whose topmost class is a
- direct subclass of tree->class. */
- {
- objc_class_tree *new_tree
- = create_tree_of_subclasses_inherited_from (class, tree->class);
- tree->subclasses = list_cons (new_tree, tree->subclasses);
- DEBUG_PRINTF (" 5. class %s inserted\n", class->name);
- return tree;
- }
- }
-}
-
-/* This function inserts `class' in the right tree hierarchy classes. */
-static void
-objc_tree_insert_class (Class class)
-{
- struct objc_list *list_node;
- objc_class_tree *tree;
-
- list_node = __objc_class_tree_list;
- while (list_node)
- {
- /* Try to insert the class in this class hierarchy. */
- tree = __objc_tree_insert_class (list_node->head, class);
- if (tree)
- {
- list_node->head = tree;
- return;
- }
- else
- list_node = list_node->tail;
- }
-
- /* If the list was finished but the class hasn't been inserted, we
- don't have an existing class hierarchy that can accommodate it.
- Create a new one. */
- __objc_class_tree_list = list_cons (NULL, __objc_class_tree_list);
- __objc_class_tree_list->head = __objc_tree_insert_class (NULL, class);
-}
-
-/* Traverse tree in preorder. Used to send +load. */
-static void
-objc_preorder_traverse (objc_class_tree *tree,
- int level,
- void (*function) (objc_class_tree *, int))
-{
- struct objc_list *node;
-
- (*function) (tree, level);
- for (node = tree->subclasses; node; node = node->tail)
- objc_preorder_traverse (node->head, level + 1, function);
-}
-
-/* Traverse tree in postorder. Used to destroy a tree. */
-static void
-objc_postorder_traverse (objc_class_tree *tree,
- int level,
- void (*function) (objc_class_tree *, int))
-{
- struct objc_list *node;
-
- for (node = tree->subclasses; node; node = node->tail)
- objc_postorder_traverse (node->head, level + 1, function);
- (*function) (tree, level);
-}
-
-/* Used to print a tree class hierarchy. */
-#ifdef DEBUG
-static void
-__objc_tree_print (objc_class_tree *tree, int level)
-{
- int i;
-
- for (i = 0; i < level; i++)
- printf (" ");
- printf ("%s\n", tree->class->name);
-}
-#endif
-
-/* Walks on a linked list of methods in the reverse order and executes
- all the methods corresponding to the `+load' selector. Walking in
- the reverse order assures the +load of class is executed first and
- then +load of categories because of the way in which categories are
- added to the class methods. This function needs to be called with
- the objc_runtime_mutex locked. */
-static void
-__objc_send_load_using_method_list (struct objc_method_list *method_list, Class class)
-{
- static SEL load_selector = 0;
- int i;
-
- if (!method_list)
- return;
-
- /* This needs no lock protection because we are called with the
- objc_runtime_mutex locked. */
- if (!load_selector)
- load_selector = sel_registerName ("load");
-
- /* method_list is a linked list of method lists; since we're
- executing in reverse order, we need to do the next list before we
- do this one. */
- __objc_send_load_using_method_list (method_list->method_next, class);
-
- /* Search the method list. */
- for (i = 0; i < method_list->method_count; i++)
- {
- struct objc_method *mth = &method_list->method_list[i];
-
- /* We are searching for +load methods that we haven't executed
- yet. */
- if (mth->method_name && sel_eq (mth->method_name, load_selector)
- && ! objc_hash_is_key_in_hash (__objc_load_methods, mth->method_imp))
- {
- /* Add this method into the +load hash table, so we won't
- execute it again next time. */
- objc_hash_add (&__objc_load_methods,
- mth->method_imp,
- mth->method_imp);
-
- /* Call +load. */
- DEBUG_PRINTF (" begin of [%s +load]\n", class->name);
- (*mth->method_imp) ((id)class, mth->method_name);
- DEBUG_PRINTF (" end of [%s +load]\n", class->name);
-
- break;
- }
- }
-}
-
-/* This function needs to be called with the objc_runtime_mutex
- locked. */
-static void
-__objc_send_load (objc_class_tree *tree,
- int level __attribute__ ((__unused__)))
-{
- Class class = tree->class;
- struct objc_method_list *method_list = class->class_pointer->methods;
-
- DEBUG_PRINTF ("+load: need to send load to class '%s'\n", class->name);
- __objc_send_load_using_method_list (method_list, class);
-}
-
-static void
-__objc_destroy_class_tree_node (objc_class_tree *tree,
- int level __attribute__ ((__unused__)))
-{
- objc_free (tree);
-}
-
-/* This is used to check if the relationship between two classes
- before the runtime completely installs the classes. */
-static BOOL
-class_is_subclass_of_class (Class class, Class superclass)
-{
- for (; class != Nil;)
- {
- if (class == superclass)
- return YES;
- class = class_superclass_of_class (class);
- }
-
- return NO;
-}
-
-/* This list contains all the classes in the runtime system for whom
- their superclasses are not yet known to the runtime. */
-static struct objc_list *unresolved_classes = 0;
-
-/* Extern function used to reference the Object class. */
-extern void __objc_force_linking (void);
-
-void
-__objc_force_linking (void)
-{
- extern void __objc_linking (void);
- __objc_linking ();
-}
-
-/* Run through the statics list, removing modules as soon as all its
- statics have been initialized. */
-static void
-objc_init_statics (void)
-{
- struct objc_list **cell = &uninitialized_statics;
- struct objc_static_instances **statics_in_module;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- while (*cell)
- {
- int module_initialized = 1;
-
- for (statics_in_module = (*cell)->head;
- *statics_in_module; statics_in_module++)
- {
- struct objc_static_instances *statics = *statics_in_module;
- Class class = objc_getClass (statics->class_name);
-
- if (! class)
- {
- /* It is unfortunate that this will cause all the
- statics initialization to be done again (eg, if we
- already initialized constant strings, and are now
- initializing protocols, setting module_initialized to
- 0 would cause constant strings to be initialized
- again). It would be good to be able to track if we
- have already initialized some of them. */
- module_initialized = 0;
- }
- else
- {
- /* Note that if this is a list of Protocol objects, some
- of them may have been initialized already (because
- they were attached to classes or categories, and the
- class/category loading code automatically fixes them
- up), and some of them may not. We really need to go
- through the whole list to be sure! Protocols are
- also special because we want to register them and
- register all their selectors. */
- id *inst;
-
- if (strcmp (statics->class_name, "Protocol") == 0)
- {
- /* Protocols are special, because not only we want
- to fix up their class pointers, but we also want
- to register them and their selectors with the
- runtime. */
- for (inst = &statics->instances[0]; *inst; inst++)
- __objc_init_protocol ((struct objc_protocol *)*inst);
- }
- else
- {
- /* Other static instances (typically constant
- strings) are easier as we just fix up their class
- pointers. */
- for (inst = &statics->instances[0]; *inst; inst++)
- (*inst)->class_pointer = class;
- }
- }
- }
- if (module_initialized)
- {
- /* Remove this module from the uninitialized list. */
- struct objc_list *this = *cell;
- *cell = this->tail;
- objc_free (this);
- }
- else
- cell = &(*cell)->tail;
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* This function is called by constructor functions generated for each
- module compiled. (_GLOBAL_$I$...) The purpose of this function is
- to gather the module pointers so that they may be processed by the
- initialization routines as soon as possible. */
-void
-__objc_exec_class (struct objc_module *module)
-{
- /* Have we processed any constructors previously? This flag is used
- to indicate that some global data structures need to be
- built. */
- static BOOL previous_constructors = 0;
-
- static struct objc_list *unclaimed_categories = 0;
-
- /* The symbol table (defined in objc-private/module-abi-8.h)
- generated by gcc. */
- struct objc_symtab *symtab = module->symtab;
-
- /* The statics in this module. */
- struct objc_static_instances **statics
- = symtab->defs[symtab->cls_def_cnt + symtab->cat_def_cnt];
-
- /* Entry used to traverse hash lists. */
- struct objc_list **cell;
-
- /* The table of selector references for this module. */
- struct objc_selector *selectors = symtab->refs;
-
- int i;
-
- DEBUG_PRINTF ("\n__objc_exec_class (%p) - start processing module...\n", module);
-
- /* Check gcc version. */
- init_check_module_version (module);
-
- /* On the first call of this routine, initialize some data
- structures. */
- if (! previous_constructors)
- {
- /* Initialize thread-safe system. */
- __objc_init_thread_system ();
- __objc_runtime_threads_alive = 1;
- __objc_runtime_mutex = objc_mutex_allocate ();
-
- __objc_init_selector_tables ();
- __objc_init_class_tables ();
- __objc_init_dispatch_tables ();
- duplicate_classes = objc_hash_new (8,
- (hash_func_type)objc_hash_ptr,
- objc_compare_ptrs);
- __objc_load_methods = objc_hash_new (128,
- (hash_func_type)objc_hash_ptr,
- objc_compare_ptrs);
- __objc_protocols_init ();
- __objc_accessors_init ();
- __objc_sync_init ();
- previous_constructors = 1;
- }
-
- /* Save the module pointer so that later we remember to call +load
- on all classes and categories on it. */
- objc_mutex_lock (__objc_runtime_mutex);
- __objc_module_list = list_cons (module, __objc_module_list);
-
- /* Replace referenced selectors from names to SELs. */
- if (selectors)
- {
- DEBUG_PRINTF (" registering selectors\n");
- __objc_register_selectors_from_module (selectors);
- }
-
- /* Parse the classes in the load module and gather selector
- information. */
- for (i = 0; i < symtab->cls_def_cnt; ++i)
- {
- Class class = (Class) symtab->defs[i];
- const char *superclass = (char *) class->super_class;
-
- /* Make sure we have what we think. */
- assert (CLS_ISCLASS (class));
- assert (CLS_ISMETA (class->class_pointer));
- DEBUG_PRINTF (" installing class '%s'\n", class->name);
-
- /* Workaround for a bug in clang: Clang may set flags other than
- _CLS_CLASS and _CLS_META even when compiling for the
- traditional ABI (version 8), confusing our runtime. Try to
- wipe these flags out. */
- if (CLS_ISCLASS (class))
- __CLS_INFO (class) = _CLS_CLASS;
- else
- __CLS_INFO (class) = _CLS_META;
-
- /* Initialize the subclass list to be NULL. In some cases it
- isn't and this crashes the program. */
- class->subclass_list = NULL;
-
- if (__objc_init_class (class))
- {
- /* Check to see if the superclass is known in this point. If
- it's not add the class to the unresolved_classes list. */
- if (superclass && ! objc_getClass (superclass))
- unresolved_classes = list_cons (class, unresolved_classes);
- }
- }
-
- /* Process category information from the module. */
- for (i = 0; i < symtab->cat_def_cnt; ++i)
- {
- struct objc_category *category = symtab->defs[i + symtab->cls_def_cnt];
- Class class = objc_getClass (category->class_name);
-
- /* If the class for the category exists then append its
- methods. */
- if (class)
- {
- DEBUG_PRINTF (" installing category '%s (%s)'\n", category->class_name, category->category_name);
- /* Do instance methods. */
- if (category->instance_methods)
- class_add_method_list (class, category->instance_methods);
-
- /* Do class methods. */
- if (category->class_methods)
- class_add_method_list ((Class) class->class_pointer,
- category->class_methods);
-
- if (category->protocols)
- {
- __objc_init_protocols (category->protocols);
- __objc_class_add_protocols (class, category->protocols);
- }
-
- /* Register the instance methods as class methods, this is
- only done for root classes. */
- __objc_register_instance_methods_to_class (class);
- }
- else
- {
- DEBUG_PRINTF (" delaying installation of category '%s (%s)'\n", category->class_name, category->category_name);
- /* The object to which the category methods belong can't be
- found. Save the information. */
- unclaimed_categories = list_cons (category, unclaimed_categories);
- }
- }
-
- if (statics)
- uninitialized_statics = list_cons (statics, uninitialized_statics);
- if (uninitialized_statics)
- objc_init_statics ();
-
- /* Scan the unclaimed category hash. Attempt to attach any
- unclaimed categories to objects. */
- for (cell = &unclaimed_categories; *cell; )
- {
- struct objc_category *category = (*cell)->head;
- Class class = objc_getClass (category->class_name);
-
- if (class)
- {
- DEBUG_PRINTF (" installing (delayed) category '%s (%s)'\n", category->class_name, category->category_name);
- list_remove_head (cell);
-
- if (category->instance_methods)
- class_add_method_list (class, category->instance_methods);
-
- if (category->class_methods)
- class_add_method_list ((Class) class->class_pointer,
- category->class_methods);
-
- if (category->protocols)
- {
- __objc_init_protocols (category->protocols);
- __objc_class_add_protocols (class, category->protocols);
- }
-
- /* Register the instance methods as class methods, this is
- only done for root classes. */
- __objc_register_instance_methods_to_class (class);
- }
- else
- cell = &(*cell)->tail;
- }
-
- if (unclaimed_proto_list && objc_getClass ("Protocol"))
- {
- list_mapcar (unclaimed_proto_list,
- (void (*) (void *))__objc_init_protocols);
- list_free (unclaimed_proto_list);
- unclaimed_proto_list = 0;
- }
-
- objc_send_load ();
-
- /* Check if there are no unresolved classes (ie, classes whose
- superclass has not been loaded yet) and that the 'Object' class,
- used as the class of classes, exist. If so, it is worth
- "resolving the class links" at this point, which will setup all
- the class/superclass pointers. */
- if (!unresolved_classes && objc_getClass ("Object"))
- {
- DEBUG_PRINTF (" resolving class links\n");
- __objc_resolve_class_links ();
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-
- DEBUG_PRINTF ("__objc_exec_class (%p) - finished processing module...\n\n", module);
-}
-
-/* This function needs to be called with the objc_runtime_mutex
- locked. */
-static void
-objc_send_load (void)
-{
- if (!__objc_module_list)
- return;
-
- /* Try to find out if all the classes loaded so far also have their
- superclasses known to the runtime. We suppose that the objects
- that are allocated in the +load method are in general of a class
- declared in the same module. */
- if (unresolved_classes)
- {
- Class class = unresolved_classes->head;
-
- while (objc_getClass ((char *) class->super_class))
- {
- list_remove_head (&unresolved_classes);
- if (unresolved_classes)
- class = unresolved_classes->head;
- else
- break;
- }
-
- /* If we still have classes for whom we don't have yet their
- super classes known to the runtime we don't send the +load
- messages (and call the load callback) yet. */
- if (unresolved_classes)
- return;
- }
-
- /* Special check. If 'Object', which is used by meta-classes, has
- not been loaded yet, delay sending of +load. */
- if (! objc_getClass ("Object"))
- return;
-
- /* Iterate over all modules in the __objc_module_list and call on
- them the __objc_create_classes_tree function. This function
- creates a tree of classes that resembles the class hierarchy. */
- list_mapcar (__objc_module_list,
- (void (*) (void *)) __objc_create_classes_tree);
-
- while (__objc_class_tree_list)
- {
-#ifdef DEBUG
- objc_preorder_traverse (__objc_class_tree_list->head,
- 0, __objc_tree_print);
-#endif
- objc_preorder_traverse (__objc_class_tree_list->head,
- 0, __objc_send_load);
- objc_postorder_traverse (__objc_class_tree_list->head,
- 0, __objc_destroy_class_tree_node);
- list_remove_head (&__objc_class_tree_list);
- }
-
- /* For each module, call the _objc_load_callback if any is
- defined. */
- list_mapcar (__objc_module_list, (void (*) (void *)) __objc_call_load_callback);
-
- /* Empty the list of modules. */
- list_free (__objc_module_list);
- __objc_module_list = NULL;
-}
-
-static void
-__objc_create_classes_tree (struct objc_module *module)
-{
- /* The runtime mutex is locked at this point */
- struct objc_symtab *symtab = module->symtab;
- int i;
-
- /* Iterate through classes defined in this module and insert them in
- the classes tree hierarchy. */
- for (i = 0; i < symtab->cls_def_cnt; i++)
- {
- Class class = (Class) symtab->defs[i];
-
- if (!objc_hash_is_key_in_hash (duplicate_classes, class))
- objc_tree_insert_class (class);
- }
-
- /* Now iterate over "claimed" categories too (ie, categories that
- extend a class that has already been loaded by the runtime), and
- insert them in the classes tree hiearchy too. Otherwise, if you
- add a category, its +load method would not be called if the class
- is already loaded in the runtime. It the category is
- "unclaimed", ie, we haven't loaded the main class yet, postpone
- sending +load as we want to execute +load from the class before
- we execute the one from the category. */
- for (i = 0; i < symtab->cat_def_cnt; ++i)
- {
- struct objc_category *category = symtab->defs[i + symtab->cls_def_cnt];
- Class class = objc_getClass (category->class_name);
-
- /* If the class for the category exists then append its
- methods. */
- if (class)
- objc_tree_insert_class (class);
- }
-}
-
-static void
-__objc_call_load_callback (struct objc_module *module)
-{
- if (_objc_load_callback)
- {
- /* The runtime mutex is locked at this point. */
- struct objc_symtab *symtab = module->symtab;
- int i;
-
- /* Iterate through classes defined in this module and call the callback
- for each one. */
- for (i = 0; i < symtab->cls_def_cnt; i++)
- {
- Class class = (Class) symtab->defs[i];
-
- if (!objc_hash_is_key_in_hash (duplicate_classes, class))
- {
- /* Call the _objc_load_callback for this class. */
- DEBUG_PRINTF (" calling the load callback for class '%s'\n", class->name);
- _objc_load_callback (class, 0);
- }
- }
-
- /* Call the _objc_load_callback for categories. Don't register
- the instance methods as class methods for categories to root
- classes since they were already added in the class. */
- for (i = 0; i < symtab->cat_def_cnt; i++)
- {
- struct objc_category *category = symtab->defs[i + symtab->cls_def_cnt];
- Class class = objc_getClass (category->class_name);
-
- DEBUG_PRINTF (" calling the load callback for category '%s (%s)'\n",
- category->class_name, category->category_name);
- _objc_load_callback (class, category);
- }
- }
-}
-
-/* Sanity check the version of gcc used to compile `module'. */
-static void
-init_check_module_version (struct objc_module *module)
-{
- if ((module->version != OBJC_VERSION) || (module->size != sizeof (struct objc_module)))
- {
- _objc_abort ("Module %s version %d doesn't match runtime %d\n",
- module->name, (int)module->version, OBJC_VERSION);
- }
-}
-
-/* __objc_init_class must be called with __objc_runtime_mutex already
- locked. Return YES if the class could be setup; return NO if the
- class could not be setup because a class with the same name already
- exists. */
-BOOL
-__objc_init_class (Class class)
-{
- /* Store the class in the class table and assign class numbers. */
- if (__objc_add_class_to_hash (class))
- {
- /* Register all of the selectors in the class and meta class. */
- __objc_register_selectors_from_class (class);
- __objc_register_selectors_from_class ((Class) class->class_pointer);
-
- /* Install the fake dispatch tables. */
- __objc_install_premature_dtable (class);
- __objc_install_premature_dtable (class->class_pointer);
-
- /* Register the instance methods as class methods, this is only
- done for root classes. */
- __objc_register_instance_methods_to_class (class);
-
- if (class->protocols)
- __objc_init_protocols (class->protocols);
-
- return YES;
- }
- else
- {
- /* The module contains a duplicate class. Remember it so that
- we will ignore it later. */
- DEBUG_PRINTF (" duplicate class '%s' - will be ignored\n", class->name);
- objc_hash_add (&duplicate_classes, class, class);
- return NO;
- }
-}
-
-/* __objc_init_protocol must be called with __objc_runtime_mutex
- already locked, and the "Protocol" class already registered. */
-static void
-__objc_init_protocol (struct objc_protocol *protocol)
-{
- static Class proto_class = 0;
-
- if (! proto_class)
- proto_class = objc_getClass ("Protocol");
-
- if (((size_t)protocol->class_pointer) == PROTOCOL_VERSION)
- {
- /* Assign class pointer. */
- protocol->class_pointer = proto_class;
-
- /* Register all the selectors in the protocol with the runtime.
- This both registers the selectors with the right types, and
- it also fixes up the 'struct objc_method' structures inside
- the protocol so that each method_name (a char * as compiled
- by the compiler) is replaced with the appropriate runtime
- SEL. */
- if (protocol->class_methods)
- __objc_register_selectors_from_description_list (protocol->class_methods);
-
- if (protocol->instance_methods)
- __objc_register_selectors_from_description_list (protocol->instance_methods);
-
- /* Register the protocol in the hashtable or protocols by
- name. */
- __objc_protocols_add_protocol (protocol->protocol_name, protocol);
-
- /* Init super protocols. */
- __objc_init_protocols (protocol->protocol_list);
- }
- else if (protocol->class_pointer != proto_class)
- {
- _objc_abort ("Version %d doesn't match runtime protocol version %d\n",
- (int) ((char *) protocol->class_pointer
- - (char *) 0),
- PROTOCOL_VERSION);
- }
-}
-
-static void
-__objc_init_protocols (struct objc_protocol_list *protos)
-{
- size_t i;
- static Class proto_class = 0;
-
- if (! protos)
- return;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- if (! proto_class)
- proto_class = objc_getClass ("Protocol");
-
- if (! proto_class)
- {
- unclaimed_proto_list = list_cons (protos, unclaimed_proto_list);
- objc_mutex_unlock (__objc_runtime_mutex);
- return;
- }
-
-#if 0
- assert (protos->next == 0); /* Only single ones allowed. */
-#endif
-
- for (i = 0; i < protos->count; i++)
- {
- struct objc_protocol *aProto = protos->list[i];
- __objc_init_protocol (aProto);
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-static void
-__objc_class_add_protocols (Class class, struct objc_protocol_list *protos)
-{
- if (! protos)
- return;
-
- protos->next = class->protocols;
- class->protocols = protos;
-}
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
new file mode 100644
index 000000000000..ec9280a80b2c
--- /dev/null
+++ b/libgcobol/intrinsic.cc
@@ -0,0 +1,838 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+/* Operational note for COBOL intrinsic functions:
+
+ In general, these functions take two parameters.
+
+ The second is an array of cblc_refer_t values, which establish the
+ cobol data identifiers used by the function. The first is a size_t
+ indicating the size of the array.
+
+ */
+
+#include <time.h>
+#include <math.h>
+#include <algorithm>
+#include <cctype>
+
+#include "libgcobol.h"
+#include "intrinsic.h"
+#include "charmaps.h"
+
+#pragma GCC diagnostic ignored "-Wformat-truncation"
+
+static double
+YMD_to_JD(int Y, int M, int D)
+ {
+ // Calculates the Julian Day
+ if( M <= 2 )
+ {
+ Y -= 1 ;
+ M += 12;
+ }
+ double A = floor(Y/100.);
+ double B = 2. - A + floor(A/4.);
+
+ double JD;
+ JD = floor(365.25 * double(Y + 4716) + floor((30.6001 * double(M+1)))) + D + B -1524.5 ;
+
+ return JD;
+ }
+
+static void
+JD_to_YMD(int &YY, int &MM, int &DD, double JD)
+ {
+ JD += 0.5;
+ double Z = floor(JD);
+ double F = JD - Z;
+ double A;
+ if( Z < 2299161.0 )
+ {
+ A = Z;
+ }
+ else
+ {
+ double alpha = floor( (Z-1867216.25) / 36524.25 ) ;
+ A = Z + 1.0 + alpha - floor(alpha/4.0);
+ }
+ double B = A + 1524;
+ double C = floor( (B - 122.1)/365.25 );
+ double D = floor( 365.25 * C );
+ double E = floor( (B-D)/30.6001 );
+
+ DD = (int)( B - D - floor(30.6001 * E) + F );
+ MM = (int)( E < 14 ? E - 1 : E - 13 );
+ YY = (int)( MM > 2 ? C - 4716 : C - 4715 );
+ }
+
+static
+char *
+timespec_to_string(struct timespec &tp)
+ {
+ /*
+ Returns a 21-character string:
+
+ 1 - 4 Four numeric digits of the year in the Gregorian calendar
+ 5 - 6 Two numeric digits of the month of the year, in the range 01 through 12
+ 7 - 8 Two numeric digits of the day of the month, in the range 01 through 31
+ 9 - 10 Two numeric digits of the hours past midnight, in the range 00 through 23
+ 11 - 12 Two numeric digits of the minutes past the hour, in the range 00 through 59
+ 13 - 14 Two numeric digits of the seconds past the minute, in the range 00 through 59
+ 15 - 16 Two numeric digits of the hundredths of a second past the second, in the range
+ 17 Either the character '-' or the character '+'.
+ 18 - 19 If character position 17 is '-', two numeric digits are returned in the range 00
+ through 12 indicating the number of hours that the reported time is behind
+ Greenwich mean time.
+
+ If character position 17 is '+', two numeric digits are
+ returned in the range 00 through 13 indicating the number of hours that the
+ reported time is ahead of Greenwich mean time. If character position 17 is '0', the
+ value 00 is returned.
+ 20 - 21 Two numeric digits are returned in the range 00 through 59 indicating the number
+ of additional minutes that the reported time is ahead of or behind Greenwich
+ mean time, depending on whether character position 17
+ */
+
+ const int size_of_buffer = 23;
+ const int offset_to_hundredths = 14;
+ const long nanoseconds_to_hundredths = 10000000;
+
+ char *retval = (char *)malloc(size_of_buffer);
+
+ // Convert the nanosecond fraction to hundredths of a second:
+ char achCentiseconds[3];
+ snprintf(achCentiseconds, 3, "%2.2ld", (tp.tv_nsec/nanoseconds_to_hundredths) );
+
+ // Convert the epoch seconds to broken-down time:
+ struct tm tm;
+ localtime_r(&tp.tv_sec, &tm);
+
+ // Format the time as per COBOL specifications, leaving two spaces for the
+ // hundredths of seconds:
+ strftime(retval, size_of_buffer, "%Y%m%d%H%M%S %z", &tm);
+
+ // Copy the 100ths into place:
+ memcpy(retval+offset_to_hundredths, achCentiseconds, 2);
+
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__current_date()
+ {
+ // Get epoch time, with fractional seconds:
+ struct timespec tp;
+ clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec
+
+ char *retval = timespec_to_string(tp);
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__when_compiled(size_t tv_sec, long tv_nsec)
+ {
+ struct timespec tp;
+ tp.tv_sec = tv_sec;
+ tp.tv_nsec = tv_nsec;
+
+ char *retval = timespec_to_string(tp);
+ return retval;
+ }
+
+#define JD_OF_1601_01_02 2305812.5
+
+extern "C"
+int
+__gg__integer_of_date(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs == 1);
+
+ int hyphen;
+ int rdigits;
+
+ long argument_1 = (long)(__gg__binary_value_from_refer(&hyphen, &rdigits, &inputs[0]));
+
+ int retval = 0;
+ static const int max_days[13] = {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
+
+ int year = (long)argument_1/10000;
+ int month = (long)argument_1/100 % 100;
+ int day = (long)argument_1 % 100;
+ // We need to check for validity in the proleptic Gregorian calendar.
+
+ int max_day = 0;
+ if( month >= 1 && month <= 12 )
+ {
+ max_day = max_days[month];
+ }
+ if( max_day == 28 && (((year%4) == 0 && ((year)%100) != 0) || ((year%400) == 0) ))
+ {
+ // Year is divisible by four, but is not divisible by 100, so this
+ // is a leap year.
+ max_day += 1;
+ }
+ if( day < 1 || day > max_day )
+ {
+ max_day = 0;
+ }
+ if( max_day && year >= 1601 && year <= 9999 )
+ {
+ // It's a valid Y/M/D:
+ double JD = YMD_to_JD(year, month, day);
+
+ // Offset result so that 1601-01-01 comes back as
+ retval = (int)(JD - JD_OF_1601_01_02);
+ }
+ return retval;
+ }
+
+extern "C"
+int
+__gg__date_of_integer(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs == 1);
+
+ int hyphen;
+ int rdigits;
+
+ double JD = (double)__gg__binary_value_from_refer(&hyphen, &rdigits, &inputs[0]);
+ JD += JD_OF_1601_01_02;
+ int Y;
+ int M;
+ int D;
+ JD_to_YMD(Y, M, D, JD);
+ int retval = Y*10000 + M*100 + D;
+ return retval;
+ }
+
+
+extern "C"
+char *
+__gg__char(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs == 1);
+
+ int hyphen;
+ int rdigits;
+
+ // The CHAR function takes an integer, the ordinal position. It
+ // returns a single-character string, which is the character is the
+ // character at that ordinal position.
+
+ // 'A', with the ascii value of 65, is at the ordinal position 66.
+
+ int ordinal = (int)(__gg__binary_value_from_refer( &hyphen,
+ &rdigits,
+ &inputs[0]));
+ int ch = ordinal-1;
+
+ char *retval = (char *)malloc(1+1);
+ retval[0] = ch;
+ retval[1] = '\0';
+
+ // The routine that called us expects to get everything back in ASCII, and
+ // it will convert it to EBCDIC, if necessary. So, if we happen to be
+ // running in EBCDIC, we have to convert the EBCDIC to ASCII so that it'll
+ // get converted back to EBCDIC.
+
+ internal_to_ascii(retval, strlen(retval));
+ return retval;
+ }
+
+extern "C"
+int
+__gg__ord(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ // We get our input in internal_character form.
+ assert(ninputs == 1);
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[0], &input);
+
+ char *arg = (char *)input.location;
+
+ // The ORD function takes a single-character string and returns the
+ // ordinal position of that character.
+
+ // In ASCII mode, an A is 0x41, so we return 0x42
+ // In EBCDIC mode, an A is 0xC1, so we return 0xC2
+
+ int retval = (arg[0]&0xFF) + 1;
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__upper_case( size_t n, cblc_refer_t inputs[] )
+ {
+ // We are expecting a single alphanumeric string in the internal codeset.
+ // All called routines are expected to return values in the raw/ascii
+ // domain:
+
+ assert(n==1);
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[0], &input);
+
+ size_t N = input.length_trimmed;
+ char *retval = (char *)malloc( N+1 );
+
+ memcpy(retval, input.location, N);
+ retval[N]= '\0';
+ internal_to_ascii(retval, N);
+ std::transform(retval, retval + N, retval, toupper);
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__lower_case( size_t n, cblc_refer_t inputs[] )
+ {
+ // See comment for upper_case
+
+ assert(n==1);
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[0], &input);
+
+ size_t N = input.length_trimmed;
+ char *retval = (char *)malloc( N+1 );
+
+ memcpy(retval, input.location, N);
+ retval[N]= '\0';
+ internal_to_ascii(retval, N);
+ std::transform(retval, retval + N, retval, tolower);
+ return retval;
+ }
+
+extern "C"
+char *
+__gg__reverse( size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs==1);
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[0], &input);
+
+ size_t N = input.length_trimmed;
+ char *retval = (char *)malloc( N+1 );
+
+ memcpy(retval, input.location, N);
+ retval[N]= '\0';
+ internal_to_ascii(retval, N);
+ std::reverse(retval, retval + N);
+ return retval;
+ }
+
+extern "C"
+__int128
+__gg__rem( size_t n, cblc_refer_t inputs[] )
+ {
+ // We expect two numerical inputs; we calculate the remainder of
+ // first divided by second:
+ assert(n == 2);
+
+ int hyphen;
+ int rdigits;
+
+ // Pick up the first value:
+ __int128 dividend = __gg__binary_value_from_refer(&hyphen, &rdigits, &inputs[0]);
+
+ // Pick up the second:
+ __int128 divisor = __gg__binary_value_from_refer(&hyphen, &rdigits, &inputs[1]);
+
+ return dividend % divisor;
+ }
+
+extern "C"
+double
+__gg__random(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ // This creates a thread-safe pseudo-random number generator
+
+ // When seed<0, just return the next number in sequence.
+
+ // The return value is between zero and not quite one
+
+ assert(ninputs <= 1);
+
+ int hyphen;
+ int rdigits;
+
+ static struct random_data *buf = NULL;
+ static char *state = NULL;
+ static const size_t state_len = 256;
+ if( !buf )
+ {
+ buf = (random_data *)malloc(sizeof(struct random_data));
+ buf->state = NULL;
+ state = (char *)malloc(state_len);
+ initstate_r( 49081, state, state_len, buf);
+ }
+ if( ninputs )
+ {
+ int seed = (int)__gg__binary_value_from_refer(&hyphen, &rdigits, &inputs[0]);
+ srandom_r(seed, buf);
+ }
+ int32_t retval_31;
+ random_r(buf, &retval_31);
+
+ // We are going to convert this to a value between zero and not quite one:
+
+ double retval = double(retval_31) / double(0x80000000UL);
+
+ return retval;
+ }
+
+extern "C"
+double
+__gg__log(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs == 1);
+ double arg = (double)__gg__get_long_double_from_refer(&inputs[0]);
+ return log(arg);
+ }
+
+extern "C"
+double
+__gg__log10(size_t ninputs, cblc_refer_t inputs[] )
+ {
+ assert(ninputs == 1);
+ double arg = (double)__gg__get_long_double_from_refer(&inputs[0]);
+ return log10(arg);
+ }
+
+struct input_state
+ {
+ size_t nsubscript;
+ bool *subscript_alls;
+ size_t *subscripts;
+ size_t *subscript_limits;
+ bool done;
+
+ void allocate(size_t N)
+ {
+ nsubscript = N;
+ if(N)
+ {
+ subscript_alls = (bool *) malloc(nsubscript);
+ subscripts = (size_t *)malloc(nsubscript);
+ subscript_limits = (size_t *)malloc(nsubscript);
+ }
+ done = false;
+ }
+ void deallocate()
+ {
+ if(nsubscript)
+ {
+ free(subscript_alls);
+ free(subscripts);
+ free(subscript_limits);
+ }
+ }
+ };
+
+struct refer_state_for_all
+ {
+ size_t nflags;
+ size_t coefficients [MAXIMUM_TABLE_DIMENSIONS];
+ size_t capacities [MAXIMUM_TABLE_DIMENSIONS];
+ size_t limits [MAXIMUM_TABLE_DIMENSIONS];
+ };
+
+static
+void
+build_refer_state_for_all( refer_state_for_all &state,
+ cblc_resolved_t &resolved)
+ {
+
+ memset(&state, 0, sizeof(refer_state_for_all) );
+ if( resolved.all_flags )
+ {
+ // At this point, resolved points to the very first element of
+ // an array specification that includes at least one ALL subscript. At
+ // this time, those ALLs were calculated as if they had been replaced
+ // with one.
+
+ // We are going to walk the reference up to its ultimate parent, picking
+ // up what we need along the way.
+
+ size_t current_bit = 1;
+ size_t current_index = 0;
+ cblc_field_t *current_sizer = resolved.field;
+ while( current_sizer )
+ {
+ while( current_sizer && !current_sizer->occurs_upper )
+ {
+ // current_sizer isn't a table, which isn't unusual.
+ current_sizer = current_sizer->parent;
+ }
+
+ if( !current_sizer )
+ {
+ // We have found all of the elements in this data description
+ // that have OCCURS clauses
+ break;
+ }
+
+ // We are sitting on an occurs clause:
+
+ if( current_bit & resolved.all_flags )
+ {
+ // It is an ALL subscript:
+ state.nflags += 1;
+ state.coefficients[current_index] = 1;
+ state.capacities[current_index] = current_sizer->capacity;
+ state.limits[current_index] = current_sizer->occurs_upper;
+ if( current_sizer->depending_on )
+ {
+ int hyphen;
+ int rdigits;
+ state.limits[current_index]
+ = (size_t)__gg__binary_value_from_field(&hyphen,
+ &rdigits,
+ current_sizer->depending_on);
+ }
+ current_index += 1 ;
+ }
+
+ current_bit <<= 1;
+ current_sizer = current_sizer->parent;
+ }
+ }
+ }
+
+static
+bool
+update_refer_state_for_all( refer_state_for_all &state,
+ cblc_resolved_t &resolved)
+ {
+ bool retval = false; // Means there is nothing left
+
+ for(size_t i=0; i<state.nflags; i++)
+ {
+ state.coefficients[i] += 1;
+ resolved.location += state.capacities[i];
+ if( state.coefficients[i] <= state.limits[i] )
+ {
+ // This coefficient is within range:
+ retval = true;
+ break;
+ }
+
+ // We have used up this coefficient.
+
+ // Remove the effects of incrementing this coefficient:
+ resolved.location -= state.limits[i] * state.capacities[i];
+ // Reset the coefficient back to one:
+ state.coefficients[i] = 1;
+
+ // And continue on to the next coefficient.
+ }
+
+ return retval;
+ }
+
+extern "C"
+int
+__gg__ord_min(size_t ninputs, cblc_refer_t inputs[])
+ {
+ // Sets dest to the one-based ordinal position of the first occurrence
+ // of the biggest element in the list of refs[]
+
+ int retval = -1;
+ int running_position = -1;
+
+ cblc_field_t *best;
+ unsigned char *best_location;
+ size_t best_length;
+ int best_attr;
+
+ unsigned char *candidate_location;
+ size_t candidate_length;
+ int candidate_attr;
+
+ for( size_t i=0; i<ninputs; i++ )
+ {
+ refer_state_for_all state;
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[i], &input);
+
+ build_refer_state_for_all(state, input);
+ for(;;)
+ {
+ running_position += 1;
+ if( retval == -1)
+ {
+ // We have to initialize the comparisons:
+ retval = running_position;
+ best = input.field;
+ best_location = input.location;
+ best_length = input.length_untrimmed;
+ best_attr = input.field->attr;
+ }
+ else
+ {
+ // We need to save the current adjustments, because __gg__compare
+ // is free to modify .location
+ candidate_location = input.location;
+ candidate_length = input.length_untrimmed;
+ candidate_attr = input.field->attr;
+
+ int compare_result =
+ __gg__compare_2(
+ input.field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ best,
+ best_location,
+ best_length,
+ best_attr,
+ 0);
+ if( compare_result < 0 )
+ {
+ retval = running_position;
+ best = input.field;
+ best_location = candidate_location;
+ best_length = candidate_length;
+ best_attr = candidate_attr;
+ }
+ }
+ if( !update_refer_state_for_all(state, input) )
+ {
+ // There is nothing left to do.
+ break;
+ }
+ }
+ }
+ return retval+1;
+ }
+
+extern "C"
+int
+__gg__ord_max(size_t ninputs, cblc_refer_t inputs[])
+ {
+ // Sets dest to the one-based ordinal position of the first occurrence
+ // of the biggest element in the list of refs[]
+
+ int retval = -1;
+ int running_position = -1;
+
+ cblc_field_t *best;
+ unsigned char *best_location;
+ size_t best_length;
+ int best_attr;
+
+ unsigned char *candidate_location;
+ size_t candidate_length;
+ int candidate_attr;
+
+ for( size_t i=0; i<ninputs; i++ )
+ {
+ refer_state_for_all state;
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[i], &input);
+
+ build_refer_state_for_all(state, input);
+ for(;;)
+ {
+ running_position += 1;
+ if( retval == -1)
+ {
+ // We have to initialize the comparisons:
+ retval = running_position;
+ best = input.field;
+ best_location = input.location;
+ best_length = input.length_untrimmed;
+ best_attr = input.field->attr;
+ }
+ else
+ {
+ // We need to save the current adjustments, because __gg__compare
+ // is free to modify .location
+ candidate_location = input.location;
+ candidate_length = input.length_untrimmed;
+ candidate_attr = input.field->attr;
+
+ int compare_result =
+ __gg__compare_2(
+ input.field,
+ candidate_location,
+ candidate_length,
+ candidate_attr,
+ best,
+ best_location,
+ best_length,
+ best_attr,
+ 0);
+ if( compare_result > 0 )
+ {
+ retval = running_position;
+ best = input.field;
+ best_location = candidate_location;
+ best_length = candidate_length;
+ best_attr = candidate_attr;
+ }
+ }
+ if( !update_refer_state_for_all(state, input) )
+ {
+ // There is nothing left to do.
+ break;
+ }
+ }
+ }
+ return retval+1;
+ }
+
+extern "C"
+char *
+__gg__trim(size_t n, cblc_refer_t inputs[])
+ {
+ assert(n==2);
+
+ cblc_resolved_t input;
+ __gg__refer_resolve(&inputs[0], &input);
+
+ int hyphen;
+ int rdigits;
+ __int128 type = __gg__binary_value_from_refer( &hyphen,
+ &rdigits,
+ &inputs[1]);
+
+ char *retval;
+ if( type == 0 )
+ {
+ // Remove leading and trailing spaces
+ char *p1 = (char *)input.location;
+ char *p2 = p1 + input.length_trimmed-1;
+
+ while( p1 <= p2 )
+ {
+ if( *p1 != internal_space && *p2 != internal_space )
+ {
+ break;
+ }
+ if( *p1 == internal_space )
+ {
+ p1 += 1;
+ }
+ if( *p2 == internal_space )
+ {
+ p2 -= 1;
+ }
+ }
+ if( p2 < p1 )
+ {
+ p2 = p1-1 ;
+ }
+ size_t length = p2 - p1 + 1 + 1;
+ retval = (char *)malloc(length);
+ char *dest = retval;
+ while( p1 <= p2 )
+ {
+ *dest++ = *p1++;
+ }
+ *dest++ = '\0';
+ }
+ else if( type == 1 )
+ {
+ // Remove leading spaces
+ char *p1 = (char *)input.location;
+ char *p2 = p1 + input.length_trimmed-1;
+
+ while( p1 <= p2 )
+ {
+ if( *p1 != internal_space )
+ {
+ break;
+ }
+ if( *p1 == internal_space )
+ {
+ p1 += 1;
+ }
+ }
+ if( p2 < p1 )
+ {
+ p2 = p1-1 ;
+ }
+ size_t length = p2 - p1 + 1 + 1;
+ retval = (char *)malloc(length);
+ char *dest = retval;
+ while( p1 <= p2 )
+ {
+ *dest++ = *p1++;
+ }
+ *dest++ = '\0';
+ }
+ else if( type == 2 )
+ {
+ // Remove trailing spaces
+ char *p1 = (char *)input.location;
+ char *p2 = p1 + input.length_trimmed-1;
+
+ while( p1 <= p2 )
+ {
+ if( *p2 != internal_space )
+ {
+ break;
+ }
+ if( *p2 == internal_space )
+ {
+ p2 -= 1;
+ }
+ }
+ if( p2 < p1 )
+ {
+ p2 = p1-1 ;
+ }
+ size_t length = p2 - p1 + 1 + 1;
+ retval = (char *)malloc(length);
+ char *dest = retval;
+ while( p1 <= p2 )
+ {
+ *dest++ = *p1++;
+ }
+ *dest++ = '\0';
+ }
+ else
+ {
+ retval = (char *)malloc(input.length_trimmed);
+ memcpy(retval, input.location, input.length_trimmed);
+ }
+
+ return retval;
+ }
+
diff --git a/libgcobol/io.cc b/libgcobol/io.cc
new file mode 100644
index 000000000000..213cf004db97
--- /dev/null
+++ b/libgcobol/io.cc
@@ -0,0 +1,89 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (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 "io.h"
+
+#include <errno.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+/*
+ * The Cobol runtime support is responsible to set the file status
+ * word appropriately to the application's expectations. This function
+ * sets the defined file status register for the file to value of the
+ * status parameter, except for FhErrno. For FhErrno, it sets the
+ * file status register to a value derived from the current value of
+ * errno. If the errno value is not accounted for, the high bit is
+ * set to 1, and the rest to errno.
+ */
+extern "C"
+unsigned int
+__gg__file_status_word( enum file_status_t status ) {
+ static uint16_t file_status_register; // for now
+
+ if( status != FsErrno ) {
+ return file_status_register = status;
+ }
+
+ // default value
+ file_status_register = (FsErrno | errno);
+
+ switch( errno ) {
+ case 0: file_status_register = 0; break;
+ case EACCES: file_status_register = FsNoAccess; break;
+ case EDQUOT: file_status_register = FsBoundary; break;
+ case EEXIST: file_status_register = FsNoAccess; break;
+ case EFAULT: file_status_register = FsNoFile; break;
+ case EFBIG: file_status_register = FsBoundary; break;
+ case EINTR: file_status_register = FsOsError; break;
+ case EINVAL: file_status_register = FsWrongType; break;
+ case EISDIR: file_status_register = FsWrongType; break;
+ case ELOOP: file_status_register = FsOsError; break;
+ case EMFILE: file_status_register = FsOsError; break;
+ case ENAMETOOLONG:
+ file_status_register = FsWrongType; break;
+ case ENFILE: file_status_register = FsOsError; break;
+ case ENODEV: file_status_register = FsNoFile; break;
+ case ENOENT: file_status_register = FsNoFile; break;
+ case ENOMEM: file_status_register = FsOsError; break;
+ case ENOSPC: file_status_register = FsBoundary; break;
+ case ENOTDIR: file_status_register = FsNoFile; break;
+ case ENXIO: file_status_register = FsNoFile; break;
+ case EOPNOTSUPP:
+ file_status_register = FsOsError; break;
+ case EOVERFLOW: file_status_register = FsBoundary; break;
+ case EPERM: file_status_register = FsNoAccess; break;
+ case EROFS: file_status_register = FsNoAccess; break;
+ case ETXTBSY: file_status_register= FsWrongType; break;
+ case EWOULDBLOCK:
+ file_status_register = FsOsError; break;
+ }
+
+ return file_status_register;
+}
diff --git a/libgcobol/ivars.c b/libgcobol/ivars.c
deleted file mode 100644
index 1e664863e1de..000000000000
--- a/libgcobol/ivars.c
+++ /dev/null
@@ -1,376 +0,0 @@
-/* GNU Objective C Runtime ivar related functions.
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h" /* For runtime structures */
-#include "objc/thr.h"
-#include "objc-private/runtime.h" /* the kitchen sink */
-#include <string.h> /* For strcmp. */
-#include <stdlib.h> /* For malloc. */
-
-struct objc_ivar *
-class_getInstanceVariable (Class class_, const char *name)
-{
- if (class_ != Nil && name != NULL && ! CLS_IS_IN_CONSTRUCTION (class_))
- {
- while (class_ != Nil)
- {
- struct objc_ivar_list *ivars = class_->ivars;
- if (ivars != NULL)
- {
- int i;
-
- for (i = 0; i < ivars->ivar_count; i++)
- {
- struct objc_ivar *ivar = &(ivars->ivar_list[i]);
-
- if (!strcmp (ivar->ivar_name, name))
- return ivar;
- }
- }
- class_ = class_getSuperclass (class_);
- }
- }
- return NULL;
-}
-
-struct objc_ivar *
-class_getClassVariable (Class class_, const char *name)
-{
- if (class_ == Nil)
- return NULL;
-
- /* Logically, since a class is an instance of its meta-class, and
- since its class methods are the instance methods of the
- meta-class, class variables should be instance variables of the
- meta-class. That is different from the normal use of having
- 'static' variables in the class implementation file, because
- every class would have its own variables.
-
- Anyway, it is all speculative at this stage, but if we get class
- variables in Objective-C, it is conceivable that this
- implementation should work. */
- return class_getInstanceVariable (class_->class_pointer, name);
-}
-
-void *
-object_getIndexedIvars (id object)
-{
- if (object == nil)
- return NULL;
- else
- return (void *)(((char *)object)
- + object->class_pointer->instance_size);
-}
-
-struct objc_ivar *
-object_getInstanceVariable (id object, const char *name, void **returnValue)
-{
- if (object == nil || name == NULL)
- return NULL;
- else
- {
- struct objc_ivar * variable = class_getInstanceVariable (object->class_pointer, name);
-
- if (variable != NULL && returnValue != NULL)
- {
- char *location = (char *)object + variable->ivar_offset;
-
- *returnValue = *((id *)location);
- }
-
- return variable;
- }
-}
-
-struct objc_ivar *
-object_setInstanceVariable (id object, const char *name, void *newValue)
-{
- if (object == nil || name == NULL)
- return NULL;
- else
- {
- struct objc_ivar * variable = class_getInstanceVariable (object->class_pointer, name);
-
- if (variable != NULL)
- {
- char *location = (char *)object + variable->ivar_offset;
-
- *((id *)location) = (id)newValue;
- }
-
- return variable;
- }
-}
-
-id object_getIvar (id object, struct objc_ivar * variable)
-{
- if (object == nil || variable == NULL)
- return nil;
- else
- {
- char *location = (char *)object + variable->ivar_offset;
-
- return *((id *)location);
- }
-}
-
-void object_setIvar (id object, struct objc_ivar * variable, id value)
-{
- if (object == nil || variable == NULL)
- return;
- else
- {
- char *location = (char *)object + variable->ivar_offset;
-
- *((id *)location) = value;
- }
-}
-
-const char * ivar_getName (struct objc_ivar * variable)
-{
- if (variable == NULL)
- return NULL;
-
- return variable->ivar_name;
-}
-
-ptrdiff_t ivar_getOffset (struct objc_ivar * variable)
-{
- if (variable == NULL)
- return 0;
-
- return (ptrdiff_t)(variable->ivar_offset);
-}
-
-const char * ivar_getTypeEncoding (struct objc_ivar * variable)
-{
- if (variable == NULL)
- return NULL;
-
- return variable->ivar_type;
-}
-
-struct objc_ivar ** class_copyIvarList (Class class_, unsigned int *numberOfReturnedIvars)
-{
- unsigned int count = 0;
- struct objc_ivar **returnValue = NULL;
- struct objc_ivar_list* ivar_list;
-
- if (class_ == Nil || CLS_IS_IN_CONSTRUCTION (class_) || !class_->ivars)
- {
- if (numberOfReturnedIvars)
- *numberOfReturnedIvars = 0;
- return NULL;
- }
-
- /* Count how many ivars we have. */
- ivar_list = class_->ivars;
- count = ivar_list->ivar_count;
-
- if (count != 0)
- {
- unsigned int i = 0;
-
- /* Allocate enough memory to hold them. */
- returnValue = (struct objc_ivar **)(malloc (sizeof (struct objc_ivar *) * (count + 1)));
-
- /* Copy the ivars. */
- for (i = 0; i < count; i++)
- returnValue[i] = &(ivar_list->ivar_list[i]);
-
- returnValue[i] = NULL;
- }
-
- if (numberOfReturnedIvars)
- *numberOfReturnedIvars = count;
-
- return returnValue;
-}
-
-BOOL
-class_addIvar (Class class_, const char * ivar_name, size_t size,
- unsigned char log_2_of_alignment, const char *type)
-{
- struct objc_ivar_list *ivars;
-
- if (class_ == Nil
- || (! CLS_IS_IN_CONSTRUCTION (class_))
- || ivar_name == NULL
- || (strcmp (ivar_name, "") == 0)
- || size == 0
- || type == NULL)
- return NO;
-
- /* Check if the class has an instance variable with that name
- already. */
- ivars = class_->ivars;
-
- if (ivars != NULL)
- {
- int i;
-
- for (i = 0; i < ivars->ivar_count; i++)
- {
- struct objc_ivar *ivar = &(ivars->ivar_list[i]);
-
- if (strcmp (ivar->ivar_name, ivar_name) == 0)
- return NO;
- }
- }
-
- /* Ok, no direct ivars. Check superclasses. */
- if (class_getInstanceVariable (objc_getClass ((char *)(class_->super_class)),
- ivar_name))
- return NO;
-
- /* Good. Create space for the new instance variable. */
- if (ivars)
- {
- int ivar_count = ivars->ivar_count + 1;
- int new_size = sizeof (struct objc_ivar_list)
- + (ivar_count - 1) * sizeof (struct objc_ivar);
-
- ivars = (struct objc_ivar_list*) objc_realloc (ivars, new_size);
- ivars->ivar_count = ivar_count;
- class_->ivars = ivars;
- }
- else
- {
- int new_size = sizeof (struct objc_ivar_list);
-
- ivars = (struct objc_ivar_list*) objc_malloc (new_size);
- ivars->ivar_count = 1;
- class_->ivars = ivars;
- }
-
- /* Now ivars is set to a list of instance variables of the right
- size. */
- {
- struct objc_ivar *ivar = &(ivars->ivar_list[ivars->ivar_count - 1]);
- unsigned int alignment = 1 << log_2_of_alignment;
- int misalignment;
-
- ivar->ivar_name = objc_malloc (strlen (ivar_name) + 1);
- strcpy ((char *)ivar->ivar_name, ivar_name);
-
- ivar->ivar_type = objc_malloc (strlen (type) + 1);
- strcpy ((char *)ivar->ivar_type, type);
-
- /* The new instance variable is placed at the end of the existing
- instance_size, at the first byte that is aligned with
- alignment. */
- misalignment = class_->instance_size % alignment;
-
- if (misalignment == 0)
- ivar->ivar_offset = class_->instance_size;
- else
- ivar->ivar_offset = class_->instance_size - misalignment + alignment;
-
- class_->instance_size = ivar->ivar_offset + size;
- }
-
- return YES;
-}
-
-
-const char *
-property_getName (struct objc_property * property __attribute__ ((__unused__)))
-{
- if (property == NULL)
- return NULL;
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on properties. */
- return NULL;
-}
-
-const char *
-property_getAttributes (struct objc_property * property __attribute__ ((__unused__)))
-{
- if (property == NULL)
- return NULL;
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on properties. */
- return NULL;
-}
-
-struct objc_property *
-class_getProperty (Class class_ __attribute__ ((__unused__)),
- const char *propertyName __attribute__ ((__unused__)))
-{
- if (class_ == NULL || propertyName == NULL)
- return NULL;
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on class properties. */
- return NULL;
-}
-
-struct objc_property **
-class_copyPropertyList (Class class_ __attribute__ ((__unused__)),
- unsigned int *numberOfReturnedProperties __attribute__ ((__unused__)))
-{
- if (class_ == Nil)
- {
- if (numberOfReturnedProperties)
- *numberOfReturnedProperties = 0;
- return NULL;
- }
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on class properties. */
- if (numberOfReturnedProperties)
- *numberOfReturnedProperties = 0;
-
- return NULL;
-}
-
-const char *
-class_getIvarLayout (Class class_ __attribute__ ((__unused__)))
-{
- return NULL;
-}
-
-const char *
-class_getWeakIvarLayout (Class class_ __attribute__ ((__unused__)))
-{
- return NULL;
-}
-
-void
-class_setIvarLayout (Class class_ __attribute__ ((__unused__)),
- const char *layout __attribute__ ((__unused__)))
-{
- return;
-}
-
-void
-class_setWeakIvarLayout (Class class_ __attribute__ ((__unused__)),
- const char *layout __attribute__ ((__unused__)))
-{
- return;
-}
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
new file mode 100644
index 000000000000..a2c0755ad1a8
--- /dev/null
+++ b/libgcobol/libgcobol.cc
@@ -0,0 +1,8180 @@
+/*
+ * Copyright (c) 2021-2022 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (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 <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 <algorithm>
+#include <unordered_map>
+
+#include "libgcobol.h"
+#include "inspect.h"
+#include "gfileio.h"
+#include "charmaps.h"
+
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+
+struct program_state
+ {
+ // These are the run-time values of these characters.
+
+ // They are always in source_code space; they get converted to native
+ // when they are used.
+ int rt_decimal_point;
+ int rt_decimal_separator;
+ int rt_quote_character;
+ int rt_low_value_character;
+ int rt_high_value_character;
+ char *rt_currency_signs[256];
+ const unsigned char *rt_collation; // 256 values;
+
+ program_state()
+ {
+ // IBM defaults to the \" QUOTE compiler option. quote_character must
+ // be set to \' when the APOST compiler option is in effect
+
+ // rt_currency_signs provides for replacing a PICTURE currency "symbol"
+ // with a character string referred to in the language specification as
+ // a "sign". The string can be an arbitrary length, allowing the
+ // replacement of, as an example, the currency <symbol> "$" with the
+ // <sign> "USD"
+
+ rt_decimal_point = ascii_period ;
+ rt_decimal_separator = ascii_comma ;
+ rt_quote_character = ascii_dquote ; // Change this with APOST
+ rt_low_value_character = DEGENERATE_LOW_VALUE ;
+ rt_high_value_character = DEGENERATE_HIGH_VALUE ;
+
+ // Set all the currency_sign pointers to NULL:
+ memset(rt_currency_signs, 0, sizeof(rt_currency_signs));
+
+ // The default collating sequence is one-to-one:
+ rt_collation = __gg__one_to_one_values;
+ }
+
+ program_state(const program_state &ps)
+ {
+ rt_decimal_point = ps.rt_decimal_point ;
+ rt_decimal_separator = ps.rt_decimal_separator ;
+ rt_quote_character = ps.rt_quote_character ;
+ rt_low_value_character = ps.rt_low_value_character ;
+ // Note throughout the code that there is special processing for the
+ // high-value character. In EBCDIC 0xFF doesn't map to ASCII 0xFF, so
+ // we are forced to avoid converting EBCDIC 0xFF.
+ rt_high_value_character = ps.rt_high_value_character ;
+ rt_collation = ps.rt_collation ;
+
+ for( int i=0; i<256; i++ )
+ {
+ if( ps.rt_currency_signs[i] )
+ {
+ rt_currency_signs[i] = strdup(ps.rt_currency_signs[i]);
+ }
+ else
+ {
+ rt_currency_signs[i] = NULL;
+ }
+ }
+ }
+
+ ~program_state()
+ {
+ for(int symbol=0; symbol<256; symbol++)
+ {
+ if( rt_currency_signs[symbol] )
+ {
+ free(rt_currency_signs[symbol]);
+ rt_currency_signs[symbol] = NULL;
+ }
+ }
+ }
+ };
+
+static std::vector<program_state> program_states;
+#define decimal_point (program_states.back().rt_decimal_point)
+#define decimal_separator (program_states.back().rt_decimal_separator)
+#define quote_character (program_states.back().rt_quote_character)
+#define low_value_character (program_states.back().rt_low_value_character)
+#define high_value_character (program_states.back().rt_high_value_character)
+#define currency_signs(a) (program_states.back().rt_currency_signs[(a)])
+#define collated(a) (program_states.back().rt_collation[(a)])
+
+static cbl_truncation_mode truncation_mode = trunc_std_e;
+
+static
+int cstrncmp( char const * const left_,
+ char const * const right_,
+ size_t count)
+ {
+ const char *left = left_;
+ const char *right = right_;
+ // This is the version of strncmp() that uses the current collation
+ int retval = 0;
+ while( count-- )
+ {
+ unsigned char chl = *left++;
+ unsigned char chr = *right++;
+ retval = chl - chr;
+ if( retval || !chl || !chr)
+ {
+ break;
+ }
+ }
+ return retval;
+ }
+
+extern "C"
+void
+__gg__decimal_point_is_comma()
+ {
+ decimal_point = ascii_comma ;
+ decimal_separator = ascii_period ;
+ }
+
+extern "C"
+void
+__gg__currency_sign_init()
+ {
+ for(int symbol=0; symbol<256; symbol++)
+ {
+ if( currency_signs(symbol) )
+ {
+ free(currency_signs(symbol));
+ currency_signs(symbol) = NULL;
+ }
+ }
+ }
+
+extern "C"
+void
+__gg__currency_sign(int symbol, const char *sign)
+ {
+ currency_signs(symbol) = strdup(sign);
+ }
+
+static int
+var_is_refmod( cblc_field_t *var )
+ {
+ return (var->attr & refmod_e) != 0;
+ }
+
+extern "C"
+__int128
+__gg__power_of_ten(int n)
+ {
+ // 2** 64 = 1.8E19
+ // 2**128 = 3.4E38
+ __int128 retval = 1;
+ static const int MAX_POWER = 19 ;
+ __int128 pos[MAX_POWER+1] =
+ {
+ 1ULL, // 00
+ 10ULL, // 01
+ 100ULL, // 02
+ 1000ULL, // 03
+ 10000ULL, // 04
+ 100000ULL, // 05
+ 1000000ULL, // 06
+ 10000000ULL, // 07
+ 100000000ULL, // 08
+ 1000000000ULL, // 09
+ 10000000000ULL, // 10
+ 100000000000ULL, // 11
+ 1000000000000ULL, // 12
+ 10000000000000ULL, // 13
+ 100000000000000ULL, // 14
+ 1000000000000000ULL, // 15
+ 10000000000000000ULL, // 16
+ 100000000000000000ULL, // 17
+ 1000000000000000000ULL, // 18
+ 10000000000000000000ULL, // 19
+ };
+ if( n < 0 || n>MAX_POWER*2) // The most we can handle is 10**38
+ {
+ fprintf(stderr, "Trying to raise 10 to %d as an int128, which we can't do.\n", n);
+ fprintf(stderr, "The problem is in %s.\n", __func__);
+ exit(1);
+ }
+ if( n <= MAX_POWER )
+ {
+ // Up to 10**18 we do directly:
+ retval = pos[n];
+ }
+ else
+ {
+ // 19 through 38:
+ retval = pos[n/2];
+ retval *= retval;
+ if( n & 1 )
+ {
+ retval *= 10;
+ }
+ }
+ return retval;
+ }
+
+extern "C"
+bool
+__gg__binary_to_string(char *result, int digits, __int128 value)
+ {
+ // The result is not terminated, because this routine is used
+ // to put information directly into cblc_field_t::data
+ // Our caller has to keep track of whether value was negative.
+
+ // Note that this routine operates in the source code-set space; that is
+ // the result comes back with zero as an ASCII 0x30, not an EBCDIC 0xF0
+
+ if( value < 0 )
+ {
+ value = -value;
+ }
+ result += digits-1 ;
+ while( digits-- )
+ {
+ *result-- = value%10 + ascii_zero;
+ value /= 10;
+ }
+ // Should value be non-zero, it means we potentially have a size error
+ return value != 0;
+ }
+
+extern "C"
+bool
+__gg__binary_to_string_internal(char *result, int digits, __int128 value)
+ {
+ // The result is not terminated, because this routine is used
+ // to put information directly into cblc_field_t::data
+ // Our caller has to keep track of whether value was negative.
+
+ // Note that this routine operates in the source code-set space; that is
+ // the result comes back with zero as an ASCII 0x30, not an EBCDIC 0xF0
+
+ if( value < 0 )
+ {
+ value = -value;
+ }
+ result += digits-1 ;
+ while( digits-- )
+ {
+ *result-- = value%10 + internal_zero;
+ value /= 10;
+ }
+ // Should value be non-zero, it means we potentially have a size error
+ return value != 0;
+ }
+
+static bool
+value_is_too_big( cblc_field_t *var,
+ __int128 value,
+ int source_rdigits)
+ {
+ // This routine is in support of arithmetic ON SIZE ERROR. It returns
+ // TRUE if var hasn't enough bytes to hold the decimal representation
+ // of value:
+ bool retval = false;
+
+ // I don't know how to describe this calculation. I came up with the
+ // equation by working a few examples. For instance, if value is 12345 and
+ // source_rdigits is two, then we are trying to cram 123.45 into 99v99999
+ // and we have a size error. So, digits is 7, rdigits is 5 and source_rdigits
+ // 2. That means we divide 12345 by 10^(7 - 5 + 2), which is 12345 / 10000,
+ // which is one, which is non-zero, which means we have a size error.
+
+ value /= __gg__power_of_ten( var->digits - var->rdigits + source_rdigits);
+ retval = value != 0;
+
+ return retval;
+ }
+
+static int
+expand_picture(char *dest, const char *picture)
+ {
+ // 'dest' must be of adequate length to hold the expanded picture string,
+ // including any extra characters due to a CURRENCY SIGN expansion.
+
+ int ch;
+ int prior_ch = NULLCH;
+ char *d = dest;
+ const char *p = picture;
+
+ long repeat;
+
+ int currency_symbol = NULLCH;
+
+ while( (ch = (*p++ & 0xFF) ) )
+ {
+ if( ch == ascii_oparen )
+ {
+ // Pick up the number after the left parenthesis
+ char *endchar;
+ repeat = strtol(p, &endchar, 10);
+
+ // We subtract one because we know that the character just before
+ // the parenthesis was already placed in dest
+ repeat -= 1;
+
+ // Update p to the character after the right parenthesis
+ p = endchar + 1;
+ while(repeat--)
+ {
+ *d++ = prior_ch;
+ }
+ }
+ else
+ {
+ prior_ch = ch;
+ *d++ = ch;
+ }
+
+ if( currency_signs(ch) )
+ {
+ // We are going to be mapping ch to a string in the final result:
+ prior_ch = ch;
+ currency_symbol = ch;
+ }
+ }
+
+ size_t dest_length = d-dest;
+
+ // We have to take into account the possibility that the currency symbol
+ // mapping might be to a string of more than one character:
+
+ if( currency_symbol )
+ {
+ size_t sign_length = strlen(currency_signs(currency_symbol)) - 1;
+ if( sign_length )
+ {
+ char *pcurrency = strchr(dest, currency_symbol);
+ assert(pcurrency);
+ memmove( pcurrency + sign_length,
+ pcurrency,
+ dest_length - (pcurrency-dest));
+ for(size_t i=0; i<sign_length; i++)
+ {
+ pcurrency[i] = ascii_B;
+ }
+ dest_length += sign_length;
+ }
+ }
+
+ return (int)(dest_length);
+ }
+
+static int Lindex(const char *dest, int length, char ch)
+ {
+ int retval = -1;
+ for(int i=0; i<length; i++)
+ {
+ if( dest[i] == ch )
+ {
+ // Finds the leftmost
+ retval = i;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static int Rindex(const char *dest, int length, char ch)
+ {
+ int retval = -1;
+ for(int i=0; i<length; i++)
+ {
+ if( dest[i] == ch )
+ {
+ // Finds the rightmost
+ retval = i;
+ }
+ }
+ return retval;
+ }
+
+static bool
+string_to_numeric_edited( char * const dest,
+ char *source, // In source characters
+ int rdigits,
+ int is_negative,
+ const char *picture)
+ {
+ // We need to expand the picture string. We assume that the caller left
+ // enough room in dest to take the expanded picture string.
+
+ int dlength = expand_picture(dest, picture);
+
+ // This is the length of the source string, which is all digits, and has
+ // an implied decimal point at the rdigits place. We assume that any
+ // source_period or ascii_V in the picture is in the right place
+ const int slength = (int)strlen(source);
+
+ // As a setting up exercise, let's deal with the possibility of a CR/DB:
+ if( dlength >= 2 )
+ {
+ // It's a positive number, so we might have to get rid of a CR or DB:
+ char ch1 = toupper(dest[dlength-2]);
+ char ch2 = toupper(dest[dlength-1]);
+ if( (ch1 == ascii_D && ch2 == ascii_B)
+ || (ch1 == ascii_C && ch2 == ascii_R) )
+ {
+ if( !is_negative )
+ {
+ // Per the spec, because the number is positive, those two
+ // characters become blank:
+ dest[dlength-2] = ascii_space;
+ dest[dlength-1] = ascii_space;
+ }
+ // Trim the dlength by two to reflect those two positions at the
+ // right edge, and from here on out we can ignore them.
+ dlength -= 2;
+ }
+ }
+
+ // We need to know if we have a currency picture symbol in this string:
+ unsigned char currency_picture = NULLCH; // This is the currency character in the PICTURE
+ const char *currency_sign = NULL; // This is the text we output when encountering
+ // // the currency_picture character
+ // Note that the currency_picture can be upper- or lower-case, which is why
+ // we can't treat dest[] to toupper. That makes me sad, because I have
+ // to do some tests for upper- and lower-case Z, and so on.
+ for(int i=0; i<dlength; i++)
+ {
+ int ch = (unsigned int)dest[i] & 0xFF;
+ if( currency_signs(ch) )
+ {
+ currency_picture = ch;
+ currency_sign = currency_signs(ch);
+ break;
+ }
+ }
+
+ // Calculate the position of the decimal point:
+ int decimal_point_index = slength - rdigits;
+
+ // Find the source position of the leftmost non-zero digit in source
+ int nonzero_index;
+ for(nonzero_index=0; nonzero_index<slength; nonzero_index++)
+ {
+ if( source[nonzero_index] != ascii_zero )
+ {
+ break;
+ }
+ }
+
+ bool is_zero = (nonzero_index == slength);
+
+ // Push nonzero_index to the left to account for explicit ascii_nine
+ // characters:
+ int non_native_zeros = slength - nonzero_index;
+
+ // Count up the number of nines
+ int nines = 0;
+ for(int i=0; i<dlength; i++)
+ {
+ if( dest[i] == ascii_nine )
+ {
+ nines += 1;
+ }
+ }
+ if( nines > non_native_zeros )
+ {
+ non_native_zeros = nines;
+ nonzero_index = slength - non_native_zeros;
+ if( nonzero_index < 0 )
+ {
+ nonzero_index = 0;
+ }
+ }
+ // nonzero_index is now the location of the leftmost digit that we will
+ // output as a digit. Everything to its left is a leading zero, and might
+ // get replaced with a floating replacement.
+
+ // We are now in a position to address specific situations:
+
+ // This is the case of leading zero suppression
+ if( (strchr(picture, ascii_Z)) || (strchr(picture, ascii_z)) )
+ {
+ int leftmost_indexA = Lindex(dest, dlength, ascii_Z);
+ int leftmost_indexB = Lindex(dest, dlength, ascii_z);
+ if( leftmost_indexA == -1 )
+ {
+ leftmost_indexA = leftmost_indexB;
+ }
+ if( leftmost_indexB == -1 )
+ {
+ leftmost_indexB = leftmost_indexA;
+ }
+
+ int rightmost_indexA = Lindex(dest, dlength, ascii_Z);
+ int rightmost_indexB = Lindex(dest, dlength, ascii_z);
+ if( rightmost_indexA == -1 )
+ {
+ rightmost_indexA = leftmost_indexB;
+ }
+ if( rightmost_indexB == -1 )
+ {
+ rightmost_indexB = leftmost_indexA;
+ }
+
+ int leftmost_index = std::min(leftmost_indexA, leftmost_indexB);
+ int rightmost_index = std::max(rightmost_indexA, rightmost_indexB);
+
+ // We are doing replacement editing: leading zeroes get replaced with
+ // spaces.
+ if( is_zero && nines == 0 )
+ {
+ // Corner case: The value is zero, and all numeric positions
+ // are suppressed. The result is all spaces:
+ memset(dest, ascii_space, dlength);
+ }
+ else
+ {
+ int index_s = slength-1; // Index into source string of digits
+ int index_d = dlength-1; // Index into the destination
+ bool reworked_string = false;
+
+ while(index_d >=0)
+ {
+ // Pick up the destination character that we will replace:
+ char ch_d = dest[index_d];
+
+ if( ch_d == currency_picture )
+ {
+ // We are going to lay down the currency string. Keep
+ // in mind that our caller nicely left room for it
+ size_t sign_len = strlen(currency_sign);
+ while(sign_len > 0)
+ {
+ dest[index_d--] = currency_sign[--sign_len];
+ }
+ continue;
+ }
+
+ char ch_s;
+ if( index_s < 0 )
+ {
+ // I don't think this can happen, but just in case:
+ ch_s = ascii_zero;
+ }
+ else
+ {
+ ch_s = source[index_s];
+ }
+
+ if( index_s <= nonzero_index && !reworked_string)
+ {
+ reworked_string = true;
+ // index_s is the location of the leftmost non-zero
+ // digit.
+
+ // So, we are about to enter the world of leading
+ // zeroes.
+
+ // The specification says, at this point, that
+ // all B 0 / , and . inside the floating string
+ // are to be considered part of the floating string:
+
+ // So, we edit dest[] to make that true:
+ int rlim = rightmost_index > index_d ? index_d : rightmost_index;
+
+ for(int i=leftmost_index; i<rlim; i++)
+ {
+ if( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator )
+ {
+ dest[i] = ascii_space;
+ }
+ }
+ // Any B 0 / , immediately to the right are
+ // also part of the floating_character string
+
+ for(int i=rlim+1; i<index_d; i++)
+ {
+ if( !( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator))
+ {
+ break;
+ }
+ dest[i] = ascii_space;
+ }
+ }
+
+
+ if( index_s >= decimal_point_index )
+ {
+ // We are to the right of the decimal point, and so we
+ // don't do any replacement. We either insert a character,
+ // or we replace with a digit:
+ switch(ch_d)
+ {
+ // We are to the right of the decimal point, so Z is
+ // a character position
+ case ascii_z:
+ case ascii_Z:
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+ case ascii_plus:
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_minus:
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_P:
+ case ascii_p:
+ // P-scaling has been handled by changing the value
+ // and the number of rdigits, so these characters
+ // are ignored here:
+ break;
+ default:
+ // Valid possibilities are 0 / ,
+ // Just leave them be
+ ch_s = ch_d;
+ break;
+ }
+ dest[index_d] = ch_s;
+ }
+ else
+ {
+ // We are to the left of the decimal point:
+ if( ch_d == decimal_point )
+ {
+ // Do this assignment to handle the situation where
+ // period and comma have been swapped. It's necessary
+ // because the case statement can't take a variable
+ ch_d = ascii_period;
+ }
+ switch(ch_d)
+ {
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_period:
+ case ascii_v:
+ case ascii_V:
+ ch_s = decimal_point;
+ break;
+ case ascii_plus:
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_minus:
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+
+ case ascii_z:
+ case ascii_Z:
+ if( index_s < nonzero_index)
+ {
+ // We are in the leading zeroes, so they are
+ // replaced with a space
+ ch_s = ascii_space;
+ }
+ index_s -= 1;
+ break;
+
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+
+ default:
+ // Valid possibilities are 0 / , which
+ // at this point all get replaced with spaces:
+ if( index_s < nonzero_index)
+ {
+ // We are in the leading zeroes, so they are
+ // replaced with a space
+ ch_s = ascii_space;
+ }
+ else
+ {
+ // We still have digits to send out, so the output
+ // is a copy of the PICTURE string
+ ch_s = ch_d;
+ }
+ }
+ dest[index_d] = ch_s;
+ }
+
+ index_d -= 1;
+ }
+ }
+ }
+
+ // This is the case of leading zero replacement:
+ else if( strchr(picture, ascii_asterisk) )
+ {
+ int leftmost_index = Lindex(dest, dlength, ascii_asterisk);
+ int rightmost_index = Rindex(dest, dlength, ascii_asterisk);
+ // We are doing replacement editing: leading zeroes get replaced with
+ // asterisks, except that any decimal point is put into place:
+ if( is_zero && nines == 0 )
+ {
+ // We need to re-initialize dest, because of the possibility
+ // of a CR/DB at the end of the line
+ dlength = expand_picture(dest, picture);
+
+ for(int i=0; i<dlength; i++)
+ {
+ if( dest[i] == ascii_v
+ || dest[i] == ascii_V
+ || dest[i] == decimal_point )
+ {
+ dest[i] = decimal_point;
+ }
+ else
+ {
+ dest[i] = ascii_asterisk;
+ }
+ }
+ }
+ else
+ {
+ int index_s = slength-1; // Index into source string of digits
+ int index_d = dlength-1; // Index into the destination
+ bool reworked_string = false;
+
+ while(index_d >=0)
+ {
+ // Pick up the destination character that we will replace:
+ char ch_d = dest[index_d];
+
+ if( ch_d == currency_picture )
+ {
+ // We are going to lay down the currency string. Keep
+ // in mind that our caller nicely left room for it
+ size_t sign_len = strlen(currency_sign);
+ while(sign_len > 0)
+ {
+ dest[index_d--] = currency_sign[--sign_len];
+ }
+ continue;
+ }
+
+ char ch_s;
+ if( index_s < 0 )
+ {
+ // I don't think this can happen, but just in case:
+ ch_s = ascii_zero;
+ }
+ else
+ {
+ ch_s = source[index_s];
+ }
+
+ if( index_s <= nonzero_index && !reworked_string)
+ {
+ reworked_string = true;
+ // index_s is the location of the leftmost non-zero
+ // digit.
+
+ // So, we are about to enter the world of leading
+ // zeroes.
+
+ // The specification says, at this point, that
+ // all B 0 / , and . inside the floating string
+ // are to be considered part of the floating string:
+
+ // So, we edit dest[] to make that true:
+ int rlim = rightmost_index > index_d ? index_d : rightmost_index;
+
+ for(int i=leftmost_index; i<rlim; i++)
+ {
+ if( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator )
+ {
+ dest[i] = ascii_asterisk;
+ }
+ }
+ // Any B 0 / , immediately to the right are
+ // also part of the floating_character string
+
+ for(int i=rlim+1; i<index_d; i++)
+ {
+ if( !( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator))
+ {
+ break;
+ }
+ dest[i] = ascii_asterisk;
+ }
+ }
+
+ if( index_s >= decimal_point_index )
+ {
+ // We are to the right of the decimal point, and so we
+ // don't do any replacement. We either insert a character,
+ // or we replace with a digit:
+ switch(ch_d)
+ {
+ // We are to the right of the decimal point, so asterisk
+ // is a a character position
+ case ascii_asterisk:
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+ case ascii_plus:
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_minus:
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ default:
+ // Valid possibilities are 0 / ,
+ // Just leave them be
+ ch_s = ch_d;
+ break;
+ }
+ dest[index_d] = ch_s;
+ }
+ else
+ {
+ // We are to the left of the decimal point:
+ if( ch_d == decimal_point )
+ {
+ ch_d = ascii_period;
+ }
+ switch(ch_d)
+ {
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_period:
+ case ascii_v:
+ case ascii_V:
+ ch_s = decimal_point;
+ break;
+ case ascii_plus:
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_minus:
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+
+ case ascii_asterisk:
+ if( index_s < nonzero_index)
+ {
+ // We are in the leading zeroes, so they are
+ // replaced with an asterisk
+ ch_s = ascii_asterisk;
+ }
+ index_s -= 1;
+ break;
+
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+
+ default:
+ // Valid possibilities are 0 / , which
+ // at this point all get replaced with spaces:
+ if( index_s < nonzero_index)
+ {
+ // We are in the leading zeroes, so they are
+ // replaced with our suppression character
+ ch_s = ascii_asterisk;
+ }
+ else
+ {
+ // We still have digits to send out, so the output
+ // is a copy of the PICTURE string
+ ch_s = ch_d;
+ }
+ }
+ dest[index_d] = ch_s;
+ }
+
+ index_d -= 1;
+ }
+ }
+ }
+ else
+ {
+ // At this point, we check for a floating $$, ++, or --
+ unsigned char floating_character = 0;
+
+ int leftmost_index;
+ int rightmost_index;
+
+ leftmost_index = Lindex(dest, dlength, ascii_plus);
+ rightmost_index = Rindex(dest, dlength, ascii_plus);
+ if( rightmost_index > leftmost_index)
+ {
+ floating_character = ascii_plus;
+ goto got_float;
+ }
+
+ leftmost_index = Lindex(dest, dlength, ascii_minus);
+ rightmost_index = Rindex(dest, dlength, ascii_minus);
+ if( rightmost_index > leftmost_index)
+ {
+ floating_character = ascii_minus;
+ goto got_float;
+ }
+
+ leftmost_index = Lindex(dest, dlength, currency_picture);
+ rightmost_index = Rindex(dest, dlength, currency_picture);
+ if( rightmost_index > leftmost_index)
+ {
+ floating_character = currency_picture;
+ goto got_float;
+ }
+ got_float:
+
+ if( floating_character )
+ {
+ if( is_zero && nines == 0 )
+ {
+ // Special case:
+ memset(dest, ascii_space, dlength);
+ }
+ else
+ {
+ const char *decimal_location = index(dest, decimal_point);
+ if( !decimal_location )
+ {
+ decimal_location = index(dest, ascii_v);
+ }
+ if( !decimal_location )
+ {
+ decimal_location = index(dest, ascii_V);
+ }
+ if( !decimal_location )
+ {
+ decimal_location = dest + dlength;
+ }
+ int decimal_index = (int)(decimal_location - dest);
+
+ if( rightmost_index > decimal_index )
+ {
+ rightmost_index = decimal_index -1;
+ }
+
+ int index_s = slength-1; // Index into source string of digits
+ int index_d = dlength-1; // Index into the destination
+ bool in_float_string = false;
+ bool reworked_string = false;
+
+ while(index_d >=0)
+ {
+ // Pick up the destination character that we will replace:
+ unsigned char ch_d = dest[index_d];
+ char ch_s = ascii_caret; // Flag this as being replaced
+
+ if( index_d == leftmost_index )
+ {
+ // At this point ch_d is the leftmost floating_character,
+ // which means it *must* go into the output stream,
+ // and that means we are truncating any remaining input.
+
+ // Setting nonzero_index to be one character to the right
+ // means that the following logic will think that any
+ // source characters from here on out are zeroes
+ nonzero_index = index_s+1;
+ }
+
+ if( ch_d != floating_character && ch_d == currency_picture )
+ {
+ // This is a non-floating currency_picture characger
+ // We are going to lay down the currency string. Keep
+ // in mind that our caller nicely left room for it
+ size_t sign_len = strlen(currency_sign);
+ while(sign_len > 0)
+ {
+ dest[index_d--] = currency_sign[--sign_len];
+ }
+ continue;
+ }
+ if( ch_d != floating_character && ch_d == ascii_plus )
+ {
+ // This is a non-floating plus sign
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ dest[index_d--] = ch_s;
+ continue;
+ }
+ if( ch_d != floating_character && ch_d == ascii_minus )
+ {
+ // This is a non-floating minus sign
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ dest[index_d--] = ch_s;
+ continue;
+ }
+
+ if( index_s < 0 )
+ {
+ // I don't think this can happen, but just in case:
+ ch_s = ascii_zero;
+ }
+ else
+ {
+ ch_s = source[index_s];
+ if( index_s <= nonzero_index && !reworked_string)
+ {
+ reworked_string = true;
+ // index_s is the location of the leftmost non-zero
+ // digit.
+
+ // So, we are about to enter the world of leading
+ // zeroes.
+
+ // The specification says, at this point, that
+ // all B 0 / , and . inside the floating string
+ // are to be considered part of the floating string:
+
+ // So, we edit dest[] to make that true:
+ int rlim = rightmost_index > index_d ? index_d : rightmost_index;
+
+ for(int i=leftmost_index; i<rlim; i++)
+ {
+ if( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator
+ || dest[i] == decimal_point )
+ {
+ dest[i] = floating_character;
+ }
+ }
+ // Any B 0 / , immediately to the right are
+ // also part of the floating_character string
+
+ for(int i=rlim+1; i<index_d; i++)
+ {
+ if( !( dest[i] == ascii_b
+ || dest[i] == ascii_B
+ || dest[i] == ascii_slash
+ || dest[i] == ascii_zero
+ || dest[i] == decimal_separator))
+ {
+ break;
+ }
+ dest[i] = floating_character;
+ }
+ }
+ }
+ if( index_s >= decimal_point_index )
+ {
+ // We are to the right of the decimal point, and so we
+ // don't do any replacement. We either insert a character,
+ // or we replace with a digit:
+ switch(ch_d)
+ {
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+ default:
+ if( ch_d == floating_character )
+ {
+ // We are laying down a digit
+ index_s -= 1;
+ }
+ else
+ {
+ // Valid possibilities are 0 / ,
+ // Just leave them be
+ ch_s = ch_d;
+ }
+ break;
+ }
+ dest[index_d] = ch_s;
+ }
+ else
+ {
+ // We are to the left of the decimal point:
+
+ if( ch_d == decimal_point )
+ {
+ ch_d = ascii_period;
+ }
+ else if (ch_d == floating_character)
+ {
+ if( index_s < nonzero_index )
+ {
+ // We are in the leading zeroes.
+ if( !in_float_string )
+ {
+ in_float_string = true;
+ // We have arrived at the rightmost floating
+ // character in the leading zeroes
+
+ if( floating_character == currency_picture )
+ {
+ size_t sign_len = strlen(currency_sign);
+ while(sign_len > 0)
+ {
+ dest[index_d--] = currency_sign[--sign_len];
+ }
+ continue;
+ }
+ if( floating_character == ascii_plus )
+ {
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ dest[index_d--] = ch_s;
+ continue;
+ }
+ if( floating_character == ascii_minus )
+ {
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ dest[index_d--] = ch_s;
+ continue;
+ }
+ }
+ else
+ {
+ // We are in the leading zeros and the
+ // floating character location is to our
+ // right. So, we put down a space:
+ dest[index_d--] = ascii_space;
+ continue;
+ }
+ }
+ else
+ {
+ // We hit a floating character, but we aren't
+ // yet in the leading zeroes
+ index_s -= 1;
+ dest[index_d--] = ch_s;
+ continue;
+ }
+ }
+
+ switch(ch_d)
+ {
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_period:
+ case ascii_v:
+ case ascii_V:
+ ch_s = decimal_point;
+ break;
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+
+ default:
+ // Valid possibilities are 0 / , which
+ // at this point all get replaced with spaces:
+ if( index_s < nonzero_index)
+ {
+ // We are in the leading zeroes, so they are
+ // replaced with our suppression character
+ ch_s = ascii_space;
+ }
+ else
+ {
+ // We still have digits to send out, so the output
+ // is a copy of the PICTURE string
+ ch_s = ch_d;
+ }
+ }
+ dest[index_d] = ch_s;
+ }
+
+ index_d -= 1;
+ }
+ }
+ }
+ else
+ {
+ // Simple replacement editing
+ int index_s = slength-1; // Index into source string of digits
+ int index_d = dlength-1; // Index into the destination
+
+ while(index_d >=0)
+ {
+ // Pick up the destination character that we will replace:
+ char ch_d = dest[index_d];
+
+ if( ch_d == currency_picture )
+ {
+ // We are going to lay down the currency string. Keep
+ // in mind that our caller nicely left room for it
+ size_t sign_len = strlen(currency_sign);
+ while(sign_len > 0)
+ {
+ dest[index_d--] = currency_sign[--sign_len];
+ }
+ continue;
+ }
+
+ char ch_s;
+ if( index_s < 0 )
+ {
+ // I don't think this can happen, but just in case:
+ ch_s = ascii_zero;
+ }
+ else
+ {
+ ch_s = source[index_s];
+ }
+ switch(ch_d)
+ {
+ // We are to the right of the decimal point, so Z is
+ // a character position
+ case ascii_nine:
+ index_s -= 1;
+ break;
+ case ascii_b:
+ case ascii_B:
+ ch_s = ascii_space;
+ break;
+ case ascii_plus:
+ if( !is_negative )
+ {
+ ch_s = ascii_plus;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ case ascii_minus:
+ if( !is_negative )
+ {
+ ch_s = ascii_space;
+ }
+ else
+ {
+ ch_s = ascii_minus;
+ }
+ break;
+ default:
+ // Valid possibilities are 0 / ,
+ // Just leave whatever is here alone
+ ch_s = ch_d;
+ break;
+ }
+ dest[index_d--] = ch_s;
+ }
+ }
+ }
+ bool retval = false;
+
+ return retval;
+ }
+
+static void
+binary_to_big_endian( unsigned char *dest,
+ int bytes,
+ __int128 value
+ )
+ {
+ if( value < 0 )
+ {
+ memset(dest, 0xFF, bytes);
+ }
+ else
+ {
+ memset(dest, 0x00, bytes);
+ }
+
+ dest += bytes-1;
+ while( bytes-- )
+ {
+ *dest-- = (unsigned char) value;
+ value >>= 8;
+ }
+ }
+
+static void
+binary_to_little_endian( unsigned char *dest,
+ int bytes,
+ __int128 value
+ )
+ {
+ if( value < 0 )
+ {
+ memset(dest, 0xFF, bytes);
+ }
+ else
+ {
+ memset(dest, 0x00, bytes);
+ }
+ memcpy(dest, &value, bytes);
+ }
+
+extern "C"
+void
+__gg__string_to_alpha_edited( char *dest,
+ char *source,
+ int slength,
+ char *picture)
+ {
+ // Put the PICTURE into the data area. If the caller didn't leave enough
+ // room, well, poo on them. Said another way; if they specify disaster,
+ // disaster is what they will get.
+
+ // This routine expands picture into dest using ascii characters, but
+ // replaces them with internal characters
+
+ int destlength = expand_picture(dest, picture);
+
+ int dindex = 0;
+ int sindex = 0;
+
+ while( dindex < destlength )
+ {
+ char dch = dest[dindex];
+ char sch;
+ switch(dch)
+ {
+ case ascii_b: // Replaced with space
+ case ascii_B:
+ dest[dindex] = internal_space;
+ break;
+
+ case ascii_zero: // These are left alone:
+ dest[dindex] = ascii_to_internal(ascii_zero);
+ break;
+
+ case ascii_slash:
+ dest[dindex] = ascii_to_internal(ascii_slash);
+ break;
+
+ default:
+ // We assume that the parser isn't giving us a bad PICTURE
+ // string, which means this character should be X, A, or 9
+ // We don't check; we just replace it:
+ if(sindex < slength)
+ {
+ sch = source[sindex++];
+ }
+ else
+ {
+ sch = internal_space;
+ }
+ dest[dindex] = sch;
+ }
+ dindex += 1;
+ }
+ }
+
+static void
+turn_sign_bit_on(unsigned char *location)
+ {
+ if( internal_is_ebcdic )
+ {
+ *location &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ else
+ {
+ *location |= NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ }
+
+static void
+turn_sign_bit_off(unsigned char *location)
+ {
+ if( internal_is_ebcdic )
+ {
+ *location |= NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ else
+ {
+ *location &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ }
+
+static bool
+is_sign_bit_on(char ch)
+ {
+ bool retval;
+ if( internal_is_ebcdic )
+ {
+ retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) == 0;
+ }
+ else
+ {
+ retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0;
+ }
+ return retval;
+ }
+
+
+extern "C"
+void
+__gg__string_to_alpha_edited_ascii( char *dest,
+ char *source,
+ int slength,
+ char *picture)
+ {
+ char *dupe = (char *)malloc(slength);
+ memcpy(dupe, source, slength);
+ ascii_to_internal_str(dupe, slength);
+ __gg__string_to_alpha_edited(dest, dupe, slength, picture);
+ free(dupe);
+ }
+
+static void
+scale_and_assign_internal( cblc_field_t *var,
+ unsigned char *location,
+ size_t length,
+ __int128 value,
+ int source_rdigits,
+ enum rounded_t rounded,
+ bool *perror)
+ {
+ // This routine takes a numerical value, and scales and converts it to the
+ // target field type.
+
+ // It operates in the source codeset space, and converts the final result
+ // to the native codeset space
+
+ bool size_error = false;
+
+ // There are a couple of reasons for adjusting the var->rdigits:
+
+ int target_rdigits = var->rdigits;
+ if( var->attr & intermediate_e )
+ {
+ // The target is an intermediate, meaning that we want to
+ // Make sure our intermediate target has room to hold
+ // the value we've been given:
+ var->rdigits = source_rdigits;
+ target_rdigits = source_rdigits;
+ }
+ else if( var->attr & scaled_e )
+ {
+ // Our target is scaled. No matter which way we are going, the result
+ // going into memory has no decimal places.
+ target_rdigits = 0;
+
+ // We have some additional scaling of value to do to make things line up.
+
+ if( var->rdigits >= 0 )
+ {
+ // Our target is something like PPPPPP999, meaning that var->actual_length
+ // is 3, and var->rdigits is 6.
+
+ // By rights, our caller should have given us something like 123 with
+ // source_rdigits of 9. So, we multiply by 10**9 to put the 123 just
+ // to the left of the decimal point, so that they line up with the
+ // target_rdigits of zero we are targeting:
+ source_rdigits -= var->digits + var->rdigits;
+ if(source_rdigits < 0)
+ {
+ // We overshot
+ value *= __gg__power_of_ten(-source_rdigits);
+ source_rdigits = 0;
+ }
+ }
+ else
+ {
+ // Our target is something like 999PPPPPP, so there is a ->digits
+ // of 3 and var->rdigits of -6.
+
+ // If our caller gave us 123000000, we need to effectively divide
+ // it by 1000000 to line up the 123 with where we want it to go:
+
+ source_rdigits += (-var->rdigits);
+ }
+ // Either way, we now have everything aligned for the remainder of the
+ // processing to work:
+ }
+
+ // Convert the scale of value to match the scale of var
+ if( source_rdigits < target_rdigits )
+ {
+ // Multiply value by ten until the source_rdigits match
+ value *= __gg__power_of_ten(target_rdigits - source_rdigits);
+ source_rdigits = target_rdigits;
+ }
+
+ if( source_rdigits > target_rdigits )
+ {
+ // We're going to divide value by 10 until we are within
+ // one rdigit:
+ value /= __gg__power_of_ten(source_rdigits - (target_rdigits+1));
+ source_rdigits = (target_rdigits+1);
+ // value now has one extra digit to the right:
+ if( rounded == rounded_e )
+ {
+ // At the present time, we can only perform ROUNDED-AWAY-FROM-ZERO
+ if( value < 0 )
+ {
+ value -= 5;
+ }
+ else
+ {
+ value += 5;
+ }
+ }
+ value /= 10;
+ }
+
+ // Value is now scaled to the target's target_rdigits
+
+ int is_negative = value < 0 ;
+
+ if( !(var->attr & signable_e) && is_negative )
+ {
+ if(false)
+ {
+ // I believe the COBOL spec allows for throwing INCOMPATIBLE-DATA
+ // errors. <sound effect: can being kicked down road>
+ printf( "runtime exception: assigning negative "
+ "value to unsigned variable %s\n",
+ var->name);
+ }
+ // Take the absolute value of value
+ value = -value;
+ is_negative = false;
+ }
+
+ // And now we put value where it belongs
+ switch( var->type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ // This is sort of a Hail Mary play. We aren't supposed to do this
+ // conversion if rdigits is non-zero. But we shouldn't have gotten
+ // here if rdigits is non-zero. So, we'll just go with the flow.
+
+ // Note that sending a signed value to an alphanumeric strips off
+ // any plus or minus signs.
+ size_error = __gg__binary_to_string_internal( (char *)location,
+ length, value);
+ break;
+
+ case FldNumericDisplay:
+ if( var->attr & signable_e )
+ {
+ // Things get exciting when a numeric-display value is signable
+
+ if( var->attr & separate_e )
+ {
+ // Whether positive or negative, a sign there will be:
+ char sign_ch = is_negative ? ascii_minus : ascii_plus ;
+ if( var->attr & leading_e )
+ {
+ // The sign character goes into the first location
+ size_error =
+ __gg__binary_to_string_internal((char *)(location+1),
+ length-1, value);
+ location[0] = sign_ch;
+ }
+ else
+ {
+ // The sign character goes into the last location
+ size_error =
+ __gg__binary_to_string_internal( (char *)location,
+ length-1, value);
+ location[length-1] = sign_ch;
+ }
+ }
+ else
+ {
+ // The sign information is not separate, so we put it into
+ // the number
+ size_error =
+ __gg__binary_to_string_internal(( char *)location,
+ length, value);
+ if( is_negative )
+ {
+ if( var->attr & leading_e )
+ {
+ // The sign bit goes into the first digit:
+ turn_sign_bit_on(&location[0]);
+ }
+ else
+ {
+ // The sign bit goes into the last digit:
+ turn_sign_bit_on(&location[length-1]);
+ }
+ }
+ }
+ }
+ else
+ {
+ // It's a simple positive number
+ size_error = __gg__binary_to_string_internal( (char *)location,
+ length, value);
+ }
+
+ break;
+
+ case FldNumericEdited:
+ {
+ if( value == 0 && (var->attr & blank_zero_e) )
+ {
+ memset(location, internal_space, length);
+ }
+ else
+ {
+ char ach[512];
+
+ // At this point, value is scaled to the target's rdigits
+
+ size_error = __gg__binary_to_string(ach, var->digits, value);
+ ach[var->digits] = NULLCH;
+
+ // Convert that string according to the PICTURE clause
+ size_error |= string_to_numeric_edited( (char *)location,
+ ach,
+ target_rdigits,
+ is_negative,
+ var->picture);
+ ascii_to_internal_str((char *)location, var->capacity);
+ }
+
+ break;
+ }
+
+ case FldNumericBinary:
+ case FldNumericBin4:
+ binary_to_big_endian( location,
+ length,
+ value);
+ size_error = value_is_too_big(var, value, source_rdigits);
+ break;
+
+ case FldNumericBin5:
+ case FldIndex:
+ case FldLiteral:
+ case FldLiteralN:
+ // Weirdly, this might be a figurative constant, hopefully usually
+ // ZERO. Everything but HIGH-VALUE will end up zero. HIGH-VALUE
+ // will become one, but it is, apparently harmless. The HIGH-VALUE
+ // must get processed separately elsewhere. As the author, it would
+ // be nice if I knew -- but I don't.
+ binary_to_little_endian(location,
+ length,
+ value);
+ size_error = value_is_too_big(var, value, source_rdigits);
+ break;
+
+ case FldAlphaEdited:
+ {
+ char ach[128];
+ size_error = __gg__binary_to_string(ach, length, value);
+ ach[length] = NULLCH;
+
+ // Convert that string according to the PICTURE clause
+ __gg__string_to_alpha_edited(
+ (char *)location,
+ ach,
+ strlen(ach),
+ var->picture);
+ break;
+ }
+
+ default:
+ printf("can't convert in %s()\n", __func__);
+ exit(1);
+ break;
+ }
+ if( perror )
+ {
+ *perror = size_error;
+ }
+ }
+
+static __int128
+edited_to_binary (
+ const char *ps,
+ int length,
+ int *hyphen,
+ int *rdigits
+ )
+ {
+ // This routine is used for converting NumericEdited strings to
+ // binary.
+
+ // Numeric edited strings can have all kinds of crap in them: spaces,
+ // slashes, dollar signs...you name it. It might have a minus sign at
+ // the beginning or end, or it might have CR or DB at the end.
+
+ // We are going to look for a minus sign, D (or d) and use that to flag the result
+ // as negative. We are going to look for a decimal point and count up
+ // the numerical digits to the right of it. And we are going to pretend
+ // that nothing else matters.
+
+ *hyphen = 0;
+ *rdigits = 0;
+
+ // index into the ps string
+ int index = 0;
+
+ // Create a delta_r for counting digits to the right of
+ // any decimal point. If and when we encounter a decimal point,
+ // we'll set this to one, otherwise it'll stay zero.
+ int delta_r = 0;
+
+ __int128 result = 0;
+
+ unsigned int ch;
+
+ // We need to check the last two characters. If CR or DB, then the result
+ // is negative:
+ if( length >= 2)
+ {
+ if( ((ps[length-2]&0xFF) == internal_D || (ps[length-2]&0xFF) == internal_d )
+ && ((ps[length-1]&0xFF) == internal_B || (ps[length-1]&0xFF) == internal_b ) )
+ {
+ *hyphen = 1;
+ }
+ else if( ((ps[length-2]&0xFF) == internal_C || (ps[length-2]&0xFF) == internal_c)
+ && ((ps[length-1]&0xFF) == internal_R || (ps[length-1]&0xFF) == internal_r) )
+ {
+ *hyphen = 1;
+ }
+ }
+
+ while( index < length )
+ {
+ ch = ps[index++] & 0xFF;
+ if( ch == (unsigned int)ascii_to_internal(decimal_point) )
+ {
+ delta_r = 1;
+ continue;
+ }
+ if( ch == internal_minus )
+ {
+ *hyphen = 1;
+ continue;
+ }
+
+ if( internal_0 <= ch && ch <= internal_9 )
+ {
+ result *= 10;
+ // In both EBCDIC and ASCII, this works:
+ result += ch & 0x0F ;
+ *rdigits += delta_r ;
+ continue;
+ }
+ }
+
+ if( result == 0 )
+ {
+ *hyphen = 0;
+ }
+ else if( *hyphen )
+ {
+ result = -result;
+ }
+ return result;
+ }
+
+static
+__int128
+big_endian_to_binary_signed(
+ const unsigned char *psource,
+ int capacity
+ )
+ {
+ // This subroutine takes a big-endian value of "capacity" bytes and
+ // converts it to a signed INT128. The highest order bit of the big-endian
+ // value determines whether or not the highest-order bits of the INT128
+ // return value are off or on.
+
+ __int128 retval;
+ if( *psource >= 128 )
+ {
+ retval = -1;
+ }
+ else
+ {
+ retval = 0;
+ }
+
+ // move the bytes of psource into retval, flipping them end-to-end
+ unsigned char *dest = (unsigned char *)&retval;
+ while(capacity > 0)
+ {
+ *dest++ = psource[--capacity];
+ }
+ return retval;
+ }
+
+static
+__int128
+little_endian_to_binary_signed(
+ const unsigned char *psource,
+ int capacity
+ )
+ {
+ // This subroutine takes a little-endian value of "capacity" bytes and
+ // converts it to a signed INT128. The highest order bit of the little-endian
+ // value determines whether or not the highest-order bits of the INT128
+ // return value are off or on.
+
+ __int128 result;
+
+ // Set all the bits of the result based on the sign of the source:
+ if( psource[capacity-1] >= 128 )
+ {
+ result = -1;
+ }
+ else
+ {
+ result = 0;
+ }
+
+ // Copy the low-order bytes into place:
+ memcpy(&result, psource, capacity);
+ return result;
+ }
+
+static
+__int128
+little_endian_to_binary_unsigned(
+ const unsigned char *psource,
+ int capacity
+ )
+ {
+ __int128 result = 0;
+
+ // Copy the low-order bytes into place:
+ memcpy(&result, psource, capacity);
+ return result;
+ }
+
+static
+__int128
+big_endian_to_binary_unsigned(
+ const unsigned char *psource,
+ int capacity
+ )
+ {
+ // This subroutine takes an unsigned big-endian value of "capacity" bytes and
+ // converts it to an INT128.
+
+ __int128 retval = 0 ;
+
+ // move the bytes of psource into retval, flipping them end-to-end
+ unsigned char *dest = (unsigned char *)&retval;
+ while(capacity > 0)
+ {
+ *dest++ = psource[--capacity];
+ }
+ return retval;
+ }
+
+static
+__int128
+get_binary_value_local( int *hyphen,
+ int *rdigits,
+ cblc_field_t *resolved_var,
+ unsigned char *resolved_location,
+ size_t resolved_length)
+ {
+ __int128 retval;
+
+ char ch;
+ switch( resolved_var->type )
+ {
+ case FldGroup :
+ case FldAlphanumeric :
+ case FldLiteralA :
+ // Read the data area as a dirty string:
+ retval = __gg__dirty_to_binary_internal( (const char *)resolved_location,
+ resolved_length,
+ hyphen,
+ rdigits );
+ break;
+
+ case FldNumericDisplay :
+ if( resolved_location[resolved_length-1] == DEGENERATE_HIGH_VALUE )
+ {
+ // This is a degenerate case, which violates the language
+ // specification, but nonetheless seems to be a thing. By
+ // default, HIGH-VALUE is usually assumed to be 0xFF. This is
+ // not necessarily true; HIGH-VALUE can be changed by the
+ // SPECIAL-NAMES ALPHABET clause. Furthermore, by definition,
+ // HIGH-VALUE applies *only* to text literals. However, there
+ // seems to be code out in the universe that wants to be able
+ // to compare NumericDisplay values that have been set to
+ // HIGH-VALUE. Consider, for example, code that reads from
+ // a disk file which sets the input field to HIGH-VALUE upon
+ // an end-of-file condition.
+
+ // This code detects that particular condition, and sets the
+ // resulting binary number to the maximum possible positive
+ // value.
+
+ // Turn all the bits on
+ memset( &retval, 0xFF, sizeof(retval) );
+
+ // Make it positive
+ ((unsigned char *)&retval)[sizeof(retval)-1] = 0x3F;
+ *rdigits = resolved_var->rdigits;
+ }
+ else
+ {
+ // Pick up the sign byte, and force our value to be positive
+ unsigned char *sign_byte_location;
+ if( (resolved_var->attr) & separate_e && (resolved_var->attr & leading_e) )
+ {
+ sign_byte_location = resolved_location;
+ ch = *sign_byte_location;
+ *sign_byte_location = internal_plus;
+ }
+ else if( (resolved_var->attr & separate_e) && !(resolved_var->attr & leading_e) )
+ {
+ sign_byte_location = resolved_location + resolved_length - 1;
+ ch = *sign_byte_location;
+ *sign_byte_location = internal_plus;
+ }
+ else if( (resolved_var->attr & leading_e) )
+ {
+ sign_byte_location = resolved_location;
+ ch = *sign_byte_location;
+ turn_sign_bit_off(sign_byte_location);
+ }
+ else // if( !(resolved_var->attr & leading_e) )
+ {
+ sign_byte_location = resolved_location + resolved_length - 1;
+ ch = *sign_byte_location;
+ turn_sign_bit_off(sign_byte_location);
+ }
+
+ // We know where the decimal point is because of rdigits. Because
+ // we know that it a clean string of ASCII digits, we can use the
+ // dirty converter:
+ retval = __gg__dirty_to_binary_internal( (const char *)resolved_location,
+ resolved_length,
+ hyphen,
+ rdigits );
+ *rdigits = resolved_var->rdigits;
+
+ // Restore the sign byte
+ *sign_byte_location = ch;
+
+ if( ch == internal_minus || is_sign_bit_on(ch) )
+ {
+ retval = -retval;
+ }
+ }
+ break;
+
+ case FldNumericEdited :
+ retval = edited_to_binary( (const char *)resolved_location,
+ resolved_length,
+ hyphen,
+ rdigits);
+ break;
+
+ case FldNumericBinary :
+ case FldNumericBin4:
+ if( resolved_var->attr & signable_e)
+ {
+ retval = big_endian_to_binary_signed( (const unsigned char *)resolved_location,
+ resolved_length);
+ }
+ else
+ {
+ retval = big_endian_to_binary_unsigned( (const unsigned char *)resolved_location,
+ resolved_length);
+ }
+ *rdigits = resolved_var->rdigits;
+ break;
+
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ case FldPointer:
+ if( resolved_var->attr & signable_e)
+ {
+ retval = little_endian_to_binary_signed( (const unsigned char *)resolved_location,
+ resolved_length);
+ }
+ else
+ {
+ retval = little_endian_to_binary_unsigned( (const unsigned char *)resolved_location,
+ resolved_length);
+ }
+ *rdigits = resolved_var->rdigits;
+ break;
+
+ case FldLiteral:
+ // All figurative constants have a binary value of zero. This
+ // seems odd for HIGH-VALUE, but you shouldn't be seeing a
+ // HIGH-VALUE here, anyway.
+ retval = 0;
+ *rdigits = 0;
+ break;
+
+ default:
+ printf("%s() Unknown conversion for resolved_var->type %d\n", __func__, resolved_var->type);
+ exit(1);
+ break;
+ }
+
+ if( resolved_var->attr & scaled_e )
+ {
+ // Here's where we handle a P-scaled number.
+
+ if( resolved_var->rdigits >= 0)
+ {
+ // We might be dealing with a source with a PICTURE string of
+ // PPPPPP999, which means retval is a three-digit number
+ // and resolved_var->rdigits is +6. That means we need to divide retval by
+ // 10**9, and we need to make rdigits 9
+ *rdigits = resolved_var->digits + resolved_var->rdigits;
+ }
+ else
+ {
+ // We have a source with a PIC string like 999PPPPPP, which is
+ // a capacity of 3 and a resolved_var->rdigits of -6. We need to multiply
+ // retval by +6, and make rdigits zero:
+ retval *= __gg__power_of_ten( -resolved_var->rdigits );
+ *rdigits = 0;
+ }
+ }
+
+ return retval;
+ }
+
+#pragma GCC diagnostic ignored "-Wformat-overflow"
+
+extern "C"
+char *
+__gg__get_date_yymmdd()
+ {
+ char ach[32];
+
+ time_t t = time(NULL);
+ struct tm *local = localtime(&t);
+
+ sprintf(ach,
+ "%2.2d%2.2d%2.2d",
+ local->tm_year % 100,
+ local->tm_mon+1 % 100,
+ local->tm_mday % 100 );
+
+ return strdup(ach);
+ }
+
+extern "C"
+char *
+__gg__get_date_yyyymmdd()
+ {
+ char ach[32];
+
+ time_t t = time(NULL);
+ struct tm *local = localtime(&t);
+
+ sprintf(ach,
+ "%4.4d%2.2d%2.2d",
+ local->tm_year + 1900,
+ local->tm_mon+1,
+ local->tm_mday);
+
+ return strdup(ach);
+ }
+
+extern "C"
+char *
+__gg__get_date_yyddd()
+ {
+ char ach[32];
+
+ time_t t = time(NULL);
+ struct tm *local = localtime(&t);
+
+ sprintf(ach,
+ "%2.2d%3.3d",
+ local->tm_year % 100,
+ local->tm_yday+1);
+
+ return strdup(ach);
+ }
+
+extern "C"
+char *
+__gg__get_yyyyddd()
+ {
+ char ach[32];
+
+ time_t t = time(NULL);
+ struct tm *local = localtime(&t);
+
+ sprintf(ach,
+ "%4.4d%3.3d",
+ local->tm_year + 1900,
+ local->tm_yday+1);
+
+ return strdup(ach);
+ }
+
+extern "C"
+char *
+__gg__get_date_dow()
+ {
+ char ach[32];
+
+ time_t t = time(NULL);
+ struct tm *local = localtime(&t);
+
+ sprintf(ach,
+ "%1.1d",
+ local->tm_wday == 0 ? 7 : local->tm_wday);
+
+ return strdup(ach);
+ }
+
+extern "C"
+char *
+__gg__get_date_hhmmssff()
+ {
+ char ach[32];
+
+ struct timespec tv;
+ clock_gettime(CLOCK_REALTIME, &tv);
+
+ // This routine returns local time:
+ int day_frac = (tv.tv_sec - timezone) % 86400;
+
+ int hour = (day_frac / 3600);
+ int minute = (day_frac%3600) / 60;
+ int second = (day_frac % 60);
+ int hundredths = tv.tv_nsec/10000000;
+
+ sprintf(ach,
+ "%2.2d%2.2d%2.2d%2.2d",
+ hour,
+ minute,
+ second,
+ hundredths);
+
+ return strdup(ach);
+ }
+
+extern "C"
+int __gg__setop_compare(
+ const unsigned char *candidate,
+ int capacity,
+ const unsigned char *domain)
+ {
+ // This routine is called to compare the characters of 'candidate'
+ // against the list of character pairs in 'domain'
+
+ int retval = 0;
+ unsigned char ch;
+ unsigned char l;
+ unsigned char h;
+ const unsigned char *d;
+
+ for(int i=0; i<capacity; i++)
+ {
+ ch = *candidate++;
+ d = domain;
+ retval = 0;
+ bool done = false;
+ for(;;)
+ {
+ cbl_class_type_t type = (cbl_class_type_t)*d++;
+ switch(type)
+ {
+ case class_type_end_e:
+ done = true;
+ break;
+
+ case class_type_char_pair_e:
+ l = ascii_to_internal(*d++);
+ h = ascii_to_internal(*d++);
+ if( ch >= l && ch <= h )
+ {
+ // This character is acceptable
+ retval = 1;
+ }
+ break;
+ }
+ if( retval == 1 )
+ {
+ // the candidate character was deemed acceptible, so
+ // we can break out of the loop
+ break;
+ }
+ if( done )
+ {
+ break;
+ }
+ }
+
+ // We checked the entire list of pairs for the candidate character
+ if( retval == 0 )
+ {
+ // This candidate character failed, so we don't need to check
+ // the rest of the candidates
+ break;
+ }
+ }
+
+ return retval;
+ }
+
+extern "C"
+__int128
+__gg__dirty_to_binary_source(const char *dirty,
+ int length,
+ int *hyphen,
+ int *rdigits)
+ {
+ // This routine is used for converting uncontrolled strings to a
+ // a 128-bit signed binary number.
+
+ // The string can start with a plus or minus
+ // It can contain a single embedded dot
+ // The rest of the characters have to be [0-9]
+ // Any other character, including a second dot, ends processing.
+
+ // So, a "1ABC" will yield 1; "ABC" will yield 0.
+
+ // It takes pointers to "s_hyphen" and "s_rdigits" so that it can
+ // report what it saw.
+
+ // It returns the binary result. So, 1031.2 returns 10312 and s_rdigits=1
+
+ // The binary number, if signed, is returned as a negative number.
+
+ __int128 retval = 0;
+
+ *hyphen = 0;
+ *rdigits = 0;
+
+ // Create a delta_r for counting digits to the right of
+ // any decimal point. If and when we encounter a decimal separator,
+ // we'll set this to one, otherwise it'll stay zero.
+ int delta_r = 0;
+
+ // We now loop over the remaining input characters:
+ while( length-- >0 )
+ {
+ char ch = *dirty++;
+
+ if( ch == ascii_minus )
+ {
+ *hyphen = 1;
+ continue;
+ }
+ if( ch == ascii_plus )
+ {
+ continue;
+ }
+ if( ch == decimal_point && delta_r == 0 )
+ {
+ // This is the first decimal point we've seen, so we
+ // can start counting rdigits:
+ delta_r = 1;
+ continue;
+ }
+ if( ch < ascii_0 || ch > ascii_9 )
+ {
+ // When we hit something that isn't a digit, then we are done
+ break;
+ }
+ retval *= 10;
+ retval += ch - ascii_0;
+ *rdigits += delta_r;
+ }
+ if( !retval )
+ {
+ // Because the result is zero, there can't be a minus sign
+ *hyphen = 0;
+ }
+ if( *hyphen )
+ {
+ // We saw a minus sign, so negate the result
+ retval = -retval;
+ }
+ return retval;
+ }
+
+extern "C"
+__int128
+__gg__dirty_to_binary_internal( const char *dirty,
+ int length,
+ int *hyphen,
+ int *rdigits)
+ {
+ // This routine is used for converting uncontrolled strings to a
+ // a 128-bit signed binary number.
+
+ // The string can start with a plus or minus
+ // It can contain a single embedded dot
+ // The rest of the characters have to be [0-9]
+ // Any other character, including a second dot, ends processing.
+
+ // So, a "1ABC" will yield 1; "ABC" will yield 0.
+
+ // It takes pointers to "s_hyphen" and "s_rdigits" so that it can
+ // report what it saw.
+
+ // It returns the binary result. So, 1031.2 returns 10312 and s_rdigits=1
+
+ // The binary number, if signed, is returned as a negative number.
+
+ __int128 retval = 0;
+
+ *hyphen = 0;
+ *rdigits = 0;
+
+ // Create a delta_r for counting digits to the right of
+ // any decimal point. If and when we encounter a decimal separator,
+ // we'll set this to one, otherwise it'll stay zero.
+ int delta_r = 0;
+
+ // We now loop over the remaining input characters:
+ while( length-- >0 )
+ {
+ unsigned int ch = (*dirty++)&0xFF;
+
+ if( ch == internal_minus )
+ {
+ *hyphen = 1;
+ continue;
+ }
+ if( ch == internal_plus )
+ {
+ continue;
+ }
+ if( ch == (unsigned int)ascii_to_internal(decimal_point) && delta_r == 0 )
+ {
+ // This is the first decimal point we've seen, so we
+ // can start counting rdigits:
+ delta_r = 1;
+ continue;
+ }
+ if( ch < internal_0 || ch > internal_9 )
+ {
+ // When we hit something that isn't a digit, then we are done
+ break;
+ }
+ retval *= 10;
+ retval += ch - internal_0 ;
+ *rdigits += delta_r;
+ }
+ if( !retval )
+ {
+ // Because the result is zero, there can't be a minus sign
+ *hyphen = 0;
+ }
+ if( *hyphen )
+ {
+ // We saw a minus sign, so negate the result
+ retval = -retval;
+ }
+ return retval;
+ }
+
+static void
+initialize_numeric(cblc_field_t *var, const char *converted_initial)
+ {
+ /* This routine is called to initialize
+ * case FldNumericDisplay:
+ * case FldNumericBinary:
+ * case FldNumericBin4:
+ * case FldNumericBin5:
+ * case FldIndex:
+ *
+ * It takes the value from var->initial, converts it to __int128, and
+ * from there converts it to var->data
+ */
+
+ int hyphen;
+ int rdigits;
+ __int128 value = __gg__dirty_to_binary_internal( converted_initial,
+ strlen(converted_initial),
+ &hyphen,
+ &rdigits);
+
+ if( var->attr & intermediate_e || var->type == FldLiteralN )
+ {
+ // This is an intermediate variable, so we adjust the rdigits to
+ // be what is needed:
+ var->rdigits = rdigits;
+ }
+
+ __gg__scale_and_assign_to_field(var,
+ value,
+ rdigits,
+ unrounded_e,
+ NULL);
+ }
+
+extern "C"
+long double
+__gg__get_long_double_from_refer(cblc_refer_t *var)
+ {
+ int hyphen;
+ int rdigits;
+ long double retval = (long double)__gg__binary_value_from_refer(&hyphen, &rdigits, var);
+ while(rdigits--)
+ {
+ retval /= 10.0;
+ }
+ return retval;
+ }
+
+extern "C"
+__int128
+__gg__get_integer_binary_value(cblc_field_t *var)
+ {
+ // This routine is called when a rounded integer is needed
+
+ __int128 retval;
+
+ int hyphen;
+ int rdigits;
+
+ retval = __gg__binary_value_from_field(&hyphen, &rdigits, var);
+
+ while( rdigits-- > 1)
+ {
+ retval /= 10;
+ }
+
+ if( rdigits-- == 1)
+ {
+ if( retval < 0 )
+ {
+ retval -= 5;
+ }
+ else
+ {
+ retval += 5;
+ }
+ retval /= 10;
+ }
+
+ return retval;
+ }
+
+static char *
+format_for_display_internal(cblc_field_t *var,
+ unsigned char *actual_location,
+ int actual_length)
+ {
+ // This routine creates a buffer with malloc() and fills it with the
+ // formatted display for the variable. It's up to the user to free
+ // that buffer when done with it. The generated string is null-terminated
+
+ char *retval;
+
+ int source_rdigits = var->rdigits;
+
+ if( var->attr & scaled_e )
+ {
+ source_rdigits = 0;
+ }
+
+ switch( var->type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ retval = (char *)malloc(actual_length+1);
+ if( actual_location )
+ {
+ memcpy(retval, actual_location, actual_length);
+ }
+ else
+ {
+ memset(retval, internal_query , actual_length);
+ }
+ retval[actual_length] = NULLCH;
+ break;
+
+ case FldLiteral:
+ case FldLiteralN:
+ retval = raw_to_internal(var->initial, strlen(var->initial));
+ break;
+
+ case FldNumericDisplay:
+ {
+ unsigned char *running_location = actual_location;
+ int digit_length = actual_length;
+
+ int nsize = actual_length+1; // Extra 1 for terminating NULL
+ int index = 0;
+ if( source_rdigits )
+ {
+ // We need room for the inside decimal point
+ nsize += 1;
+ }
+ if( var->attr & signable_e && !(var->attr & separate_e) )
+ {
+ // We need room for a leading sign
+ nsize += 1;
+ }
+ retval = (char *)malloc(nsize);
+
+ if( actual_location)
+ {
+ if( var->attr & signable_e )
+ {
+ if( var->attr & separate_e )
+ {
+ // Reduce the digit location count by the +/- character
+ digit_length -= 1;
+ if( var->attr & leading_e )
+ {
+ // The first character is the sign character
+ retval[index++] = *running_location++;
+ }
+ }
+ else
+ {
+ // The sign character is not separate
+ size_t sign_location = var->attr & leading_e ? 0 : actual_length-1 ;
+ if( is_sign_bit_on( actual_location[sign_location]) )
+ {
+ retval[index++] = internal_minus;
+ }
+ else
+ {
+ retval[index++] = internal_plus;
+ }
+ }
+ }
+
+ if( var_is_refmod(var) )
+ {
+ memcpy(retval+index, actual_location, actual_length);
+ index += actual_length;
+ }
+ else
+ {
+ // copy over the characters to the left of the decimal point:
+ for(int i=0; i<digit_length - source_rdigits; i++ )
+ {
+ char ch = *running_location++;
+
+ // The default HIGH-VALUE of 0xFF runs afoul of the
+ // NumericDisplay sign bit 0f 0x40 when running in
+ // ASCII mode. The following test handles that problem
+ // when HIGH-VALUE is still 0xFF. That HIGH-VALUE can
+ // be changed by the SPECIAL-NAMES ALPHABET clause. But
+
+ // I have decided that the onus of that problem is on
+ // the the user.
+ if( retval[index-1] != (char)DEGENERATE_HIGH_VALUE )
+ {
+ turn_sign_bit_off((unsigned char *)&ch);
+ }
+ retval[index++] = ch;
+ }
+ if( source_rdigits )
+ {
+ // Lay down a decimal point
+ retval[index++] = ascii_to_internal(decimal_point);
+
+ // And the digits to the right
+ for(int i=0; i<source_rdigits; i++ )
+ {
+ char ch = *running_location++;
+ if( retval[index-1] != (char)DEGENERATE_HIGH_VALUE )
+ {
+ turn_sign_bit_off((unsigned char *)&ch);
+ }
+ retval[index++] = ch;
+ }
+ }
+ }
+ if( var->attr & signable_e && var->attr & separate_e && !(var->attr & leading_e) )
+ {
+ retval[index++] = actual_location[actual_length-1];
+ }
+
+ retval[index++] =NULLCH;
+ }
+ else
+ {
+ memset(retval, internal_query, nsize-1);
+ retval[nsize] = NULLCH;
+ }
+ }
+ break;
+
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldIndex:
+ {
+ int hyphen;
+ int digits;
+ __int128 value = get_binary_value_local( &hyphen,
+ &digits,
+ var,
+ actual_location,
+ actual_length);
+ char ach[128];
+ __gg__binary_to_string_internal(ach, var->digits, value);
+
+ // And copy the code from up above:
+ int nsize = var->digits+1;
+ int index = 0;
+ if( source_rdigits )
+ {
+ // We need room for the inside decimal point
+ nsize += 1;
+ }
+ if( var->attr & signable_e )
+ {
+ // We need room for the leading sign
+ nsize += 1;
+ }
+ retval = (char *)malloc(nsize);
+
+ bool is_signed = value < 0;
+
+ if( var->attr & signable_e )
+ {
+ if( is_signed )
+ {
+ retval[index++] = internal_minus;
+ }
+ else
+ {
+ retval[index++] = internal_plus;
+ }
+ }
+ // copy over the characters to the left of the decimal point:
+ memcpy(retval+index, ach, var->digits - source_rdigits);
+ index += var->digits - source_rdigits;
+ if( source_rdigits )
+ {
+ retval[index++] = ascii_to_internal(decimal_point);
+ memcpy(retval+index, ach+(var->digits-source_rdigits), source_rdigits);
+ index += source_rdigits;
+ }
+ retval[index++] = NULLCH ;
+ }
+ break;
+
+ case FldClass:
+ {
+ if( var->level != 88 )
+ {
+ size_t retsize = 16;
+ retval = (char *)malloc(retsize);
+ memset(retval, 0, retsize);
+ strcpy(retval, "<CLASS>");
+ }
+ else
+ {
+ // This is a LEVEL 88 variable
+ size_t retsize = 16;
+ retval = (char *)malloc(retsize);
+ memset(retval, 0, retsize);
+ strcpy(retval, "<LEVEL88>");
+ }
+
+ break;
+ }
+
+ case FldPointer:
+ {
+ int hyphen;
+ int digits;
+ __int128 value = get_binary_value_local( &hyphen,
+ &digits,
+ var,
+ actual_location,
+ actual_length);
+
+ retval = (char *)malloc( 2*sizeof(void *) + 3 );
+ sprintf( retval,
+ "0x%*.*lx",
+ (int)(2*sizeof(void *)),
+ (int)(2*sizeof(void *)),
+ (unsigned long)value);
+ ascii_to_internal_str(retval, strlen(retval));
+ break;
+ }
+
+ default:
+ printf("Unknown conversion %d in format_for_display_internal\n", var->type );
+ exit(1);
+ break;
+ }
+
+ if( var->attr & scaled_e )
+ {
+ if( var->rdigits > 0)
+ {
+ // We have something like 123 or +123. We need to insert a decimal
+ // point and a rdigits zeroes to make it +.000000123
+ size_t new_length = strlen(retval) + var->rdigits + 1 + 1;
+ char *new_ret = (char *)malloc(new_length);
+ memset(new_ret, internal_0, new_length);
+ char *p = new_ret;
+ char *s = retval;
+ if( (retval[0]&0xFF) < internal_0 || (retval[0]&0xFF) > internal_9 )
+ {
+ *p++ = retval[0];
+ s += 1;
+ }
+ *p++ = ascii_to_internal(decimal_point);
+ p += var->rdigits; // Skip over the zeroes
+ strcpy(p, s);
+ free(retval);
+ retval = new_ret;
+ }
+ else // var->rdigits < 0
+ {
+ // We have something like 123 or +123. All we need to do is
+ // add zeroes to the end:
+ size_t new_length = strlen(retval) + -var->rdigits + 1;
+ char *new_ret = (char *)malloc(new_length);
+ memset(new_ret, internal_0, new_length);
+ new_ret[new_length-1] = NULLCH;
+ memcpy(new_ret, retval, strlen(retval));
+ free(retval);
+ retval = new_ret;
+ }
+ }
+
+ return retval;
+ }
+
+static char *
+format_for_display_local(cblc_resolved_t &var)
+ {
+ if(var.field)
+ {
+ // At this point, format the entire length. It's up to our caller to
+ // trim it further, because this routine is used by both receivers and
+
+ return format_for_display_internal( var.field,
+ var.location,
+ var.length_untrimmed);
+ }
+ else
+ {
+ return strdup("");
+ }
+ }
+
+static int
+compare_88( const char *list,
+ cblc_field_t * /*conditional*/,
+ unsigned char *conditional_location,
+ int conditional_length)
+ {
+ char *test;
+ if( ((int)list[0]&0xFF) == 0xFF )
+ {
+ // We are working with a figurative constant
+
+ test = (char *)malloc(conditional_length+1);
+ // This is where we handle the zero-length strings that
+ // nonetheless can magically be expanded into figurative
+ // constants:
+
+ int ch = internal_space;
+ // Check for the strings starting with 0xFF whose second character
+ // indicates a figurative constant:
+ if( list[1] == ascii_Z )
+ {
+ ch = internal_zero;
+ }
+ else if( list[1] == ascii_H )
+ {
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ ch = high_value_character;
+ }
+ else
+ {
+ ch = ascii_to_internal(high_value_character);
+ }
+ }
+ else if( list[1] == ascii_Q )
+ {
+ ch = ascii_to_internal(quote_character);
+ }
+ else // () list[1] == ascii_L )
+ {
+ ch = ascii_to_internal(low_value_character);
+ }
+ memset( test , ch, conditional_length );
+ test[conditional_length] = NULLCH;
+ }
+ else if( (int)strlen(list) < conditional_length )
+ {
+ // 'list' is too short; we have to right-fill with spaces:
+ test = (char *)malloc(conditional_length+1);
+ memset(test, internal_space, conditional_length);
+ memcpy(test, list, strlen(list));
+ test[conditional_length] = NULLCH;
+ }
+ else
+ {
+ test = strdup(list);
+ }
+
+ int cmpval;
+
+ if( test[0] == NULLCH && conditional_location[0] == 0)
+ {
+ cmpval = 0;
+ }
+ else
+ {
+ cmpval = cstrncmp(test, (char *)conditional_location, conditional_length);
+ if( cmpval == 0 && (int)strlen(test) != conditional_length )
+ {
+ // When strncmp returns 0, the actual smaller string is the
+ // the shorter of the two:
+ cmpval = (int)strlen(test) - conditional_length;
+ }
+ }
+
+ free(test);
+
+ if( cmpval < 0 )
+ {
+ cmpval = -1;
+ }
+ else if(cmpval > 0)
+ {
+ cmpval = +1;
+ }
+ return cmpval;
+ }
+
+static
+int
+compare_field_class(cblc_field_t *conditional,
+ unsigned char *conditional_location,
+ int conditional_length,
+ cblc_field_t *list)
+ {
+ int retval = 1; // Zero means equal
+ __int128 value;
+ int hyphen;
+ int rdigits;
+
+ // list->initial points to a superstring: a double-null terminated
+ // string containing pairs of strings. We are looking for equality.
+
+ switch( conditional->type )
+ {
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldIndex:
+ {
+ value = get_binary_value_local ( &hyphen,
+ &rdigits,
+ conditional,
+ conditional_location,
+ conditional_length);
+ char *walker = list->initial;
+ while(*walker)
+ {
+ __int128 first = (__int128)atoll(walker);
+ walker += strlen(walker) + 1;
+ __int128 last = (__int128)atoll(walker);
+ walker += strlen(walker) + 1;
+ if( first <= value && value <= last )
+ {
+ retval = 0;
+ break;
+ }
+ }
+ break;
+ }
+
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ {
+ char *walker = list->initial;
+ while(*walker)
+ {
+ char *first = walker;
+ walker += strlen(first) + 1;
+ char *last = walker;
+ walker += strlen(last) + 1;
+
+ int compare_result;
+
+ compare_result = compare_88(first,
+ conditional,
+ conditional_location,
+ conditional_length);
+ if( compare_result > 0 )
+ {
+ // First is > conditional, so this is no good
+ continue;
+ }
+ compare_result = compare_88(last,
+ conditional,
+ conditional_location,
+ conditional_length);
+ if( compare_result < 0 )
+ {
+ // Last is < conditional, so this is no good
+ continue;
+ }
+
+ // conditional is inclusively between first and last
+ retval = 0;
+ break;
+ }
+ break;
+ }
+
+ default:
+ printf( "%s(): doesn't know what to do with %s\n",
+ __func__,
+ conditional->name);
+ exit(1);
+ }
+
+ return retval;
+ }
+
+static
+bool local_is_numeric(int type)
+ {
+ bool retval;
+ switch(type)
+ {
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ case FldLiteralN:
+ retval = true;
+ break;
+ default:
+ retval = false;
+ break;
+ }
+ return retval;
+ }
+
+static
+bool local_is_alpha(int type)
+ {
+ bool retval;
+ switch(type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ case FldLiteral:
+ case FldLiteralA:
+ retval = true;
+ break;
+ default:
+ retval = false;
+ break;
+ }
+ return retval;
+ }
+
+static
+int
+compare_strings(char *left_string,
+ size_t left_length,
+ char *right_string,
+ size_t right_length)
+ {
+ int retval = 0;
+ size_t i = 0;
+
+ while( !retval && i<left_length && i<right_length )
+ {
+ retval = collated((unsigned char)left_string[i])
+ - collated((unsigned char)right_string[i]);
+ i += 1;
+ }
+
+ // We need to space-extend the shorter value. That's because
+ // "Bob" is equal to "Bob "
+ while( !retval && i<left_length )
+ {
+ retval = collated((unsigned char)left_string[i])
+ - collated(internal_space);
+ if( retval )
+ {
+ break;
+ }
+ i += 1;
+ }
+
+ while( !retval && i<right_length )
+ {
+ retval = collated(internal_space)
+ - collated((unsigned char)right_string[i]);
+ if( retval )
+ {
+ break;
+ }
+ i += 1;
+ }
+ return retval;
+ }
+
+extern "C"
+int
+__gg__compare_2( cblc_field_t *left_side,
+ unsigned char *left_location,
+ size_t left_length,
+ int left_attr,
+ cblc_field_t *right_side,
+ unsigned char *right_location,
+ size_t right_length,
+ int right_attr,
+ int second_time_through)
+ {
+ // First order of business: If right_side is a FldClass, pass that off
+ // to the speciality squad:
+
+ unsigned char *converted_initial = NULL;
+
+ if( right_side->type == FldClass )
+ {
+ return compare_field_class( left_side,
+ left_location,
+ left_length,
+ right_side);
+ }
+
+ // Serene in our conviction that the left_side isn't a FldClass, we
+ // move on:
+
+ cbl_figconst_t left_figconst = (cbl_figconst_t)(left_attr & FIGCONST_MASK);
+ cbl_figconst_t right_figconst = (cbl_figconst_t)(right_attr & FIGCONST_MASK);
+
+ unsigned int fig_left = 0;
+ unsigned int fig_right = 0;
+
+ switch(left_figconst)
+ {
+ case normal_value_e :
+ fig_left = 0;
+ break;
+ case low_value_e :
+ fig_left = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e :
+ fig_left = internal_zero;
+ break;
+ case space_value_e :
+ fig_left = internal_space;
+ break;
+ case quote_value_e :
+ fig_left = ascii_to_internal(quote_character);
+ break;
+ case high_value_e :
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ fig_left = high_value_character;
+ }
+ else
+ {
+ fig_left = ascii_to_internal(high_value_character);
+ }
+ break;
+ }
+ switch(right_figconst)
+ {
+ case normal_value_e :
+ fig_right = 0;
+ break;
+ case low_value_e :
+ fig_right = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e :
+ fig_right = internal_zero;
+ break;
+ case space_value_e :
+ fig_right = internal_space;
+ break;
+ case quote_value_e :
+ fig_right = ascii_to_internal(quote_character);
+ break;
+ case high_value_e :
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ fig_right = high_value_character;
+ }
+ else
+ {
+ fig_right = ascii_to_internal(high_value_character);
+ }
+ break;
+ }
+
+ // We have four high-level conditions to consider:
+ int retval;
+ bool compare = false;
+
+ if( left_figconst && right_figconst )
+ {
+ // We are comparing two figurative constants
+ retval = collated(fig_left) - collated(fig_right);
+ compare = true;
+ goto fixup_retval;
+ }
+ if( left_figconst && !right_figconst )
+ {
+ // Go directly to fixup_retval. Because 'compare' is false, we'll
+ // end up trying again with the variables swapped:
+ goto fixup_retval;
+ }
+ if( !left_figconst && right_figconst )
+ {
+ // We are comparing the left side to a figurative constant:
+ switch( right_figconst )
+ {
+ default:
+ fprintf(stderr,
+ "%s() %s:%d -- Unknown figurative constant %d\n",
+ __func__, __FILE__, __LINE__,
+ (int)right_figconst);
+ exit(1);
+ break;
+
+ case low_value_e:
+ case high_value_e:
+ case quote_value_e:
+ case space_value_e:
+ retval = 0;
+ for(size_t i=0; i<left_length; i++)
+ {
+ retval = collated((unsigned int)left_location[i])
+ - collated(fig_right);
+ if( retval )
+ {
+ break;
+ }
+ }
+
+ compare = true;
+ goto fixup_retval;
+ break;
+
+ case zero_value_e:
+ {
+ switch( left_side->type )
+ {
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldNumericDisplay:
+ case FldLiteralN:
+ case FldIndex:
+ // ZEROES is a chameleon. When compared to a numeric, it is
+ // the number zero:
+ {
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ value = get_binary_value_local(&hyphen, &rdigits, left_side, left_location, left_length);
+ retval = 0;
+ retval = value < 0 ? -1 : retval;
+ retval = value > 0 ? 1 : retval;
+ break;
+ }
+
+ default:
+ // We are comparing a alphanumeric string to ZEROES
+ retval = 0;
+ for(size_t i=0; i<left_length; i++)
+ {
+ retval = collated((unsigned int)left_location[i])
+ - collated(fig_right);
+ if( retval )
+ {
+ break;
+ }
+ }
+ compare = true;
+ break;
+ }
+ compare = true;
+ goto fixup_retval;
+ break;
+ }
+ }
+ }
+ else
+ {
+ // Neither left_side nor right_side is a figurative constant.
+
+ // Our strategy here is to compare two alphanumerics, two numerics,
+ // or an alphanumeric to a numeric. We'll handle a numeric to an
+ // alphanumeric on a second-time-through.
+
+ if( local_is_alpha(left_side->type) && local_is_alpha(right_side->type) )
+ {
+ retval = compare_strings( (char *)left_location,
+ left_length,
+ (char *)right_location,
+ right_length);
+
+ compare = true;
+ goto fixup_retval;
+ }
+
+ if( local_is_numeric(left_side->type) && local_is_numeric(right_side->type) )
+ {
+ // We are comparing a numeric to a numeric:
+ int hyphen;
+ int ldecimals;
+ int rdecimals;
+ __int128 left_value;
+ __int128 right_value;
+
+ left_value = get_binary_value_local(&hyphen, &ldecimals, left_side, left_location, left_length);
+
+ right_value = get_binary_value_local(&hyphen, &rdecimals, right_side, right_location, right_length);
+
+ // We need to align the decimal points:
+ if(rdecimals > ldecimals)
+ {
+ left_value *= __gg__power_of_ten(rdecimals-ldecimals);
+ }
+ else if( ldecimals > rdecimals )
+ {
+ right_value *= __gg__power_of_ten(ldecimals-rdecimals);
+ }
+
+ retval = 0;
+ retval = left_value < right_value ? -1 : retval;
+ retval = left_value > right_value ? 1 : retval;
+ compare = true;
+ goto fixup_retval;
+ }
+
+ if( local_is_alpha(left_side->type) && local_is_numeric(right_side->type) )
+ {
+ // We are comparing an alphanumeric to a numeric.
+
+ // The trick here is to convert the numeric to its display form,
+ // and compare that to the alphanumeric. For example, when comparing
+ // a VAL5 PIC X(3) VALUE 5 to literals,
+ //
+ // VAL5 EQUAL 5 is TRUE
+ // VAL5 EQUAL 005 is TRUE
+ // VAL5 EQUAL "5" is FALSE
+ // VAL5 EQUAL "005" is TRUE
+
+ if( left_side->type == FldLiteralA )
+ {
+ converted_initial
+ = (unsigned char *)raw_to_internal(left_side->initial,
+ strlen(left_side->initial));
+ left_location = converted_initial;
+ left_length = strlen(left_side->initial);
+ }
+
+ char *right_string = format_for_display_internal(
+ right_side,
+ right_location,
+ right_length);
+
+ // There is a tricky aspect to comparing an alphanumeric to
+ // a string. In short, we have to strip off any leading plus sign
+
+ // And, according to the NIST tests, the same is true for minus signs.
+ // Apparently, when comparing a number to an alphanumeric, it is
+ // considered a "pseudo-move", and the rule for moving a negative
+ // number to an alphanumeric is that negative signs get stripped off
+
+ if( *left_location == internal_plus || *left_location == internal_minus )
+ {
+ left_location += 1;
+ left_length -= 1;
+ }
+
+ char *right_fixed;
+ if( *right_string == internal_plus || *right_string == internal_minus )
+ {
+ right_fixed = right_string + 1;
+ }
+ else
+ {
+ right_fixed = right_string;
+ }
+
+ retval = compare_strings( (char *)left_location,
+ left_length,
+ right_fixed,
+ strlen(right_fixed));
+ free(right_string);
+ compare = true;
+ goto fixup_retval;
+ }
+ }
+
+ fixup_retval:
+
+ if( !compare && !second_time_through)
+ {
+ // This is the first time through, and we couldn't do the comparison.
+ // Maybe we have to reverse the inputs:
+ retval = __gg__compare_2( right_side,
+ right_location,
+ right_length,
+ right_attr,
+ left_side,
+ left_location,
+ left_length,
+ left_attr,
+ 1);
+ // And reverse the sense of the return value:
+ compare = true;
+ retval = -retval;
+ }
+
+ if( !compare && second_time_through )
+ {
+ // Nope. We still couldn't do the comparison
+ fprintf(stderr, "###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
+ fprintf(stderr, "###### We don't know how to compare types %d and %d\n",
+ left_side->type,
+ right_side->type);
+ assert(false);
+ }
+
+ // Normalize negative and positive to just -1 and +1
+ if( retval < 0 )
+ {
+ retval = -1;
+ }
+ else if( retval > 0)
+ {
+ retval = 1;
+ }
+ free(converted_initial);
+ return retval;
+ }
+
+extern "C"
+int
+__gg__compare( struct cblc_refer_t *left_ref,
+ struct cblc_refer_t *right_ref,
+ int second_time_through )
+ {
+ cblc_resolved_t left;
+ cblc_resolved_t right;
+
+ __gg__refer_resolve(left_ref, &left);
+ __gg__refer_resolve(right_ref, &right);
+
+ int retval = __gg__compare_2( left.field,
+ left.location,
+ left.length_trimmed,
+ left.field->attr,
+ right.field,
+ right.location,
+ right.length_trimmed,
+ right.field->attr,
+ second_time_through);
+ return retval;
+ }
+
+extern "C"
+void *
+__gg__get_stderr()
+ {
+ return stderr;
+ }
+
+static void
+file_read_into_field( cblc_file_t *file,
+ cblc_field_t *field)
+ {
+ cblc_refer_t wrapper = {};
+ cblc_refer_t dummy_key = {};
+ wrapper.field = field;
+ file->default_record = field;
+ file->record_area_size = field->capacity;
+ __gg__file_read(file,
+ &wrapper,
+ &dummy_key,
+ 0);
+ }
+
+extern "C"
+void
+__gg__long_double_to_target( cblc_field_t *tgt,
+ long double tgt_value,
+ rounded_t rounded)
+ {
+ int tgt_rdigits = 0;
+
+ if( tgt->attr & intermediate_e )
+ {
+ // We are calculating an intermediate result. We want to keep as
+ // much of the fractional part as we can. We are using a long double,
+ // which can hold about 18 digits. So, keep multiplying non-zero
+ // value by 10 until it's that big. Limit the proces to sixteen
+ // multiplies, in case we were given a ridiculously tiny number to
+ // begin with:
+ const long double digits = 1E16;
+
+ if( tgt_value )
+ {
+ while( tgt_value > -digits && tgt_value < digits && tgt_rdigits < 16 )
+ {
+ tgt_value *= 10.0;
+ tgt_rdigits += 1;
+ }
+ }
+ }
+ else
+ {
+ // We want a specific number of rdigits. We will multiply by
+ // 10^(tgt->rdigits + 1), to allow for the possibility of rounding:
+ tgt_rdigits = tgt->rdigits+1;
+ for(int i=0; i<tgt_rdigits; i++)
+ {
+ tgt_value *= 10.0;
+ }
+ }
+
+ __gg__scale_and_assign_to_field(tgt,
+ tgt_value,
+ tgt_rdigits,
+ rounded,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__long_double_to_refer( cblc_refer_t *refer,
+ long double tgt_value,
+ rounded_t rounded)
+ {
+ int tgt_rdigits = 0;
+
+ if( refer->field->attr & intermediate_e )
+ {
+ // We are calculating an intermediate result. We want to keep as
+ // much of the fractional part as we can. We are using a long double,
+ // which can hold about 18 digits. So, keep multiplying non-zero
+ // value by 10 until it's that big. Limit the proces to sixteen
+ // multiplies, in case we were given a ridiculously tiny number to
+ // begin with:
+ const long double digits = 1E16;
+
+ if( tgt_value )
+ {
+ while( tgt_value > -digits && tgt_value < digits && tgt_rdigits < 16 )
+ {
+ tgt_value *= 10.0;
+ tgt_rdigits += 1;
+ }
+ }
+ }
+ else
+ {
+ // We want a specific number of rdigits. We will multiply by
+ // 10^(tgt->rdigits + 1), to allow for the possibility of rounding:
+ tgt_rdigits = refer->field->rdigits+1;
+ for(int i=0; i<tgt_rdigits; i++)
+ {
+ tgt_value *= 10.0;
+ }
+ }
+
+ __gg__scale_to_refer( refer,
+ tgt_value,
+ tgt_rdigits,
+ rounded,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__double_to_target(cblc_field_t *tgt, double tgt_value, rounded_t rounded)
+ {
+ int tgt_rdigits = 0;
+
+ if( tgt->attr & intermediate_e )
+ {
+ // We are calculating an intermediate result. We want to keep as
+ // much of the fractional part as we can. We are using a double,
+ // which can hold about 18 digits. So, keep multiplying non-zero
+ // value by 10 until it's that big. Limit the proces to sixteen
+ // multiplies, in case we were given a ridiculously tiny number to
+ // begin with:
+ const double digits = 1E14;
+
+ if( tgt_value )
+ {
+ while( tgt_value > -digits && tgt_value < digits && tgt_rdigits < 14 )
+ {
+ tgt_value *= 10.0;
+ tgt_rdigits += 1;
+ }
+ }
+ }
+ else
+ {
+ // We want a specific number of rdigits. We will multiply by
+ // 10^(tgt->rdigits + 1), to allow for the possibility of rounding:
+ tgt_rdigits = tgt->rdigits+1;
+ for(int i=0; i<tgt_rdigits; i++)
+ {
+ tgt_value *= 10.0;
+ }
+ }
+
+ __gg__scale_and_assign_to_field(tgt,
+ tgt_value,
+ tgt_rdigits,
+ rounded,
+ NULL);
+ }
+
+extern "C"
+void
+__gg__float_to_target(cblc_field_t *tgt, float tgt_value, rounded_t rounded)
+ {
+ int tgt_rdigits = 0;
+
+ if( tgt->attr & intermediate_e )
+ {
+ // We are calculating an intermediate result. We want to keep as
+ // much of the fractional part as we can. We are using a float,
+ // which can hold about 18 digits. So, keep multiplying non-zero
+ // value by 10 until it's that big. Limit the proces to sixteen
+ // multiplies, in case we were given a ridiculously tiny number to
+ // begin with:
+ const double digits = 1E6;
+
+ if( tgt_value )
+ {
+ while( tgt_value > -digits && tgt_value < digits && tgt_rdigits < 6 )
+ {
+ tgt_value *= 10.0;
+ tgt_rdigits += 1;
+ }
+ }
+ }
+ else
+ {
+ // We want a specific number of rdigits. We will multiply by
+ // 10^(tgt->rdigits + 1), to allow for the possibility of rounding:
+ tgt_rdigits = tgt->rdigits+1;
+ for(int i=0; i<tgt_rdigits; i++)
+ {
+ tgt_value *= 10.0;
+ }
+ }
+
+ __gg__scale_and_assign_to_field(tgt,
+ tgt_value,
+ tgt_rdigits,
+ rounded,
+ NULL);
+
+ }
+
+extern "C"
+void
+__gg__pow( cblc_refer_t *result,
+ __int128 a_value,
+ __int128 b_value,
+ int a_rdigits,
+ int b_rdigits,
+ rounded_t rounded)
+ {
+ // This is going to be a simple-minded pow(a,b) routine. At this time, it
+ // can't do the range of digits that COBOL needs. But it will suffice
+ // for early development purposes:
+
+ long double avalue = a_value;
+ long double bvalue = b_value;
+
+ // convert a and b to floating point, with the decimal points in the
+ // right places:
+ for(int i=0; i<a_rdigits; i++)
+ {
+ avalue /= 10.0;
+ }
+ for(int i=0; i<b_rdigits; i++)
+ {
+ bvalue /= 10.0;
+ }
+
+ // Calculate our answer, in floating point:
+ long double tgt_value = powl(avalue, bvalue);
+ __gg__long_double_to_refer(result, tgt_value, rounded);
+ }
+
+extern "C"
+long double
+__gg__int128_to_long_double(__int128 NNN)
+ {
+ return (long double)(NNN);
+ }
+
+struct for_sort_table
+ {
+ // We are going to jump through hoops in order to use
+ // __gg__cobol_compare in the qsort() callback.
+
+ // For each comparison, we will populate these two variables with the
+ // data provided to the comparison routine, and then compare *them*
+ cblc_field_t *left_side;
+ cblc_field_t *right_side;
+
+ // The list of keys and whether they are ascending or descending.
+ size_t nkeys;
+ int *ascending;
+
+ unsigned char *bottom;
+ unsigned char *top;
+ };
+
+static int
+compare_for_sort_table(const void *e1, const void *e2, void *sorter_)
+ {
+ int retval = 0;
+ struct for_sort_table *sorter = (struct for_sort_table *)sorter_;
+
+ assert( (const unsigned char *)e1 >= sorter->bottom );
+ assert( (const unsigned char *)e2 >= sorter->bottom );
+ assert( (const unsigned char *)e1 < sorter->top );
+ assert( (const unsigned char *)e2 < sorter->top );
+
+ cblc_refer_t left_ref = {};
+ cblc_refer_t right_ref = {};
+
+ left_ref.field = sorter->left_side;
+ right_ref.field = sorter->right_side;
+
+ for(size_t i=0; i<sorter->nkeys; i++)
+ {
+ // e1 and e2 each point to an entire row of the table.
+
+ // For each key, we need to pull out the relevant piece of the row
+ // that is the actual key:
+
+ const unsigned char *key1;
+ const unsigned char *key2;
+ if( sorter->ascending[i] )
+ {
+ key1 = (const unsigned char *)e1 + sorter->left_side[i].offset;
+ key2 = (const unsigned char *)e2 + sorter->left_side[i].offset;
+ }
+ else
+ {
+ // We accomplish a descending sort by swapping the data sources
+ key1 = (const unsigned char *)e2 + sorter->left_side[i].offset;
+ key2 = (const unsigned char *)e1 + sorter->left_side[i].offset;
+ }
+
+ memcpy(sorter->left_side[i].data, key1, sorter->left_side[i].capacity);
+ memcpy(sorter->right_side[i].data, key2, sorter->right_side[i].capacity);
+
+ retval = __gg__compare(&left_ref, &right_ref, 0);
+
+ if( !retval )
+ {
+ // We are going to use the e1 and e2 pointers as a tiebreaker in
+ // order to create a stable sort.
+ retval = e1 < e2 ? -1 : 1;
+ }
+ }
+
+ return retval;
+ }
+
+
+extern "C"
+void
+__gg__sort_table( cblc_refer_t *table_,
+ size_t elements,
+ size_t nkeys,
+ cblc_field_t **keys,
+ int *ascending,
+ int /*duplicates*/)
+ {
+ struct for_sort_table sorter;
+
+ sorter.left_side = (cblc_field_t *)malloc(nkeys * sizeof(cblc_field_t));
+ sorter.right_side = (cblc_field_t *)malloc(nkeys * sizeof(cblc_field_t));
+
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ // Establish the left_side:
+ // Copy over the basic structure
+ memcpy(&sorter.left_side[i], keys[i], sizeof(cblc_field_t) );
+ // With everything else in place, adjust the allocated data:
+ sorter.left_side[i].data = (unsigned char *)malloc(sorter.left_side[i].capacity);
+
+ // Establish the right_side:
+ // Copy over the basic structure
+ memcpy(&sorter.right_side[i], keys[i], sizeof(cblc_field_t) );
+ // With everything else in place, adjust the allocated data:
+ sorter.right_side[i].data = (unsigned char *)malloc(sorter.right_side[i].capacity);
+ }
+
+ sorter.nkeys = nkeys;
+ sorter.ascending = ascending;
+
+ // With the sorter structure fully established, we can set up for qsort_r():
+
+ cblc_resolved_t table;
+ __gg__refer_resolve(table_, &table);
+
+ sorter.bottom = table.location;
+ sorter.top = table.location + elements * table.length_untrimmed;
+
+ qsort_r( table.location,
+ elements,
+ table.length_untrimmed,
+ compare_for_sort_table,
+ &sorter );
+
+ // With the in-place sort completed, we are done
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ free(sorter.left_side[i].data);
+ free(sorter.right_side[i].data);
+ }
+ free(sorter.left_side);
+ free(sorter.right_side);
+ }
+
+extern "C"
+void __gg__push_program_state()
+ {
+ program_state initial_value;
+ program_states.push_back(initial_value);
+ }
+
+extern "C"
+void __gg__pop_program_state()
+ {
+ program_states.pop_back();
+ }
+
+extern "C"
+void
+__gg__initialize_variable(cblc_field_t *var, int is_redefined)
+ {
+ // We need to make sure that the program_states vector has at least one
+ // entry in it. This happens when we are the very first PROGRAM-ID called
+ // in this module.
+
+ if( program_states.empty() )
+ {
+ __gg__push_program_state();
+ }
+
+ // We need to convert the "raw" codeset "initial" to the "internal" codeset
+ char *converted_initial = raw_to_internal(var->initial, strlen(var->initial));
+
+ if( var->type != FldClass && var->level != 88 && var->initial[0] != NULLCH )
+ {
+ // Do nothing to these types here
+ }
+ else
+ {
+ if( var->level == 88 )
+ {
+ // We need to convert the options to the internal native codeset
+
+ size_t buffer_size = 4;
+ char *buffer = (char *)malloc(buffer_size);
+
+ size_t index = 0;
+
+ cblc_field_t *parent = var->parent;
+ switch(parent->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ {
+ char *walker = var->initial;
+ while(*walker)
+ {
+ char *first;
+ char *last;
+ if( (*walker & 0xFF) == 0xFF )
+ {
+ first = strdup(walker);
+ }
+ else
+ {
+ first = raw_to_internal(walker, strlen(walker));
+ }
+ walker += strlen(first) + 1;
+
+ if( (*walker & 0xFF) == 0xFF )
+ {
+ last = strdup(walker);
+ }
+ else
+ {
+ last = raw_to_internal(walker, strlen(walker));
+ }
+ walker += strlen(last) + 1;
+ while(index + strlen(first) + strlen(last) + 3 > buffer_size)
+ {
+ buffer_size *= 2;
+ buffer = (char *)realloc(buffer, buffer_size);
+ }
+ strcpy(buffer+index, first);
+ index += strlen(first) + 1;
+ strcpy(buffer+index, last);
+ index += strlen(last) + 1;
+ free(first);
+ free(last);
+ }
+ buffer[index++] = 0;
+ break;
+ }
+ }
+ if( index > 0 )
+ {
+ buffer = (char *)realloc(buffer, index);
+ var->initial = buffer;
+ }
+ }
+ }
+
+ // First order of business: When the variable was allocated in
+ // parser_symbol_add(), only LEVEL 01 variables had memory allocated. All
+ // child variables were given NULL data pointers.
+
+ // FldLiteralA and FldLiteralA need some additional processing
+
+ bool a_parent_initialized = false;
+
+ if( !var->data && var->type == FldLiteralA)
+ {
+ var->level = 77;
+
+ var->capacity = strlen(converted_initial);
+ var->data = (unsigned char *)malloc(var->capacity);
+ }
+
+ if( !var->data && var->type == FldLiteralN)
+ {
+ var->level = 77;
+
+ int hyphen;
+ int rdigits;
+ __int128 value = __gg__dirty_to_binary_internal( converted_initial,
+ strlen(converted_initial),
+ &hyphen,
+ &rdigits);
+ if( hyphen )
+ {
+ var->attr |= signable_e;
+ }
+ var->rdigits = rdigits;
+
+ // Operating a bit on faith: Let's simply count the number of
+ // digits in the number. It turns out that certain comparisons
+ // need to know the number of digits, because "IF "2" EQUAL 002"
+ // is false, while "IF "2" EQUAL 2" is true. So, we need to
+ // count up leading zeroes.
+
+ var->digits = 0;
+ for( size_t i=0; i<strlen(converted_initial); i++ )
+ {
+ if( (converted_initial[i]&0xFF) >= internal_0
+ && (converted_initial[i]&0xFF) <= internal_9)
+ {
+ var->digits += 1;
+ }
+ }
+
+ var->capacity = 0;
+ __int128 temp = value;
+ do
+ {
+ var->capacity += 1;
+ temp /= 256;
+ } while(temp);
+
+ // Add an extra byte so that negative numbers have the two's-complement
+ // room to be negative.
+ var->capacity += 1 ;
+ if( var->capacity > 16 )
+ {
+ var->capacity = 16;
+ }
+ var->data = (unsigned char *)malloc(var->capacity);
+ }
+
+ // At this point Level 01 and Level 07 variables have data allocated.
+ // Subordinate variables still are null the first time through; we need
+ // to remedy that situation here:
+
+ if( !var->data )
+ {
+ cblc_field_t *parent = var->parent;
+ while(parent)
+ {
+ if( strlen(parent->initial) )
+ {
+ a_parent_initialized = true;
+ }
+ if(parent->level == LEVEL01 || parent->level == LEVEL77 )
+ {
+ break;
+ }
+ parent = parent->parent; // I can't help it. This just tickles me.
+ }
+ if(!parent)
+ {
+ printf("__gg__initialize_variable: %s has NULL data, but no LEVEL01 ancestor\n", var->name);
+ printf("We're crashing\n");
+ exit(1);
+ }
+ //printf(" assigning var->data to %p + %zd\n", parent->data, var->offset);
+ var->data = parent->data + var->offset;
+ }
+ if( var->attr & (linkage_e | external_e) )
+ {
+ return;
+ }
+
+ if( is_redefined || a_parent_initialized )
+ {
+ // Don't initialize variables that have the REDEFINES clause. Many things
+ // in COBOL programs don't work if you do, in particular the initialization
+ // of tables.
+
+ // Likewise, don't initialize variables with an OCCURS clause. To do so
+ // means that we will likely clobber the values in the flat data item we
+ // effectively redefine.
+ return;
+ }
+
+ // This is a little brutish, but it is nonetheless simple, effective, and
+ // not at all costly. The numeric-edited variable type can have a
+ // BLANK WHEN ZERO clause, which causes the storage to be set to spaces
+ // when receiving a value of zero. But according to the ISO/IEC 1989:2014
+ // specification, section 13.18.63.3 sentence 8, initialization is not
+ // affected by any BLANK WHEN ZERO clause.
+
+ // So, I am going to rather ham-handedly turn that bit off here, and
+ // restore it when initialization is done.
+
+ // Save this for later
+ int save_the_attribute = var->attr;
+
+ // Turn off the bit in question
+ var->attr &= ~blank_zero_e;
+
+ int capacity = var->capacity ;
+
+ size_t number_of_dimensions = 0;
+ size_t limits[MAXIMUM_TABLE_DIMENSIONS];
+ size_t capacities[MAXIMUM_TABLE_DIMENSIONS];
+ size_t dimension[MAXIMUM_TABLE_DIMENSIONS+1];
+
+ bool there_can_be_more = true;
+ if( var->occurs_upper )
+ {
+ cblc_field_t *family_tree = var;
+ while(family_tree && number_of_dimensions < MAXIMUM_TABLE_DIMENSIONS)
+ {
+ if( family_tree->occurs_upper )
+ {
+ limits[number_of_dimensions] = family_tree->occurs_upper;
+ capacities[number_of_dimensions] = family_tree->capacity;
+ dimension[number_of_dimensions] = 0;
+ number_of_dimensions += 1;
+ }
+
+ family_tree = family_tree->parent;
+ }
+
+ switch( var->type )
+ {
+ case FldIndex:
+ case FldGroup:
+ case FldClass:
+ there_can_be_more = false;
+ break;
+ default:
+ break;
+ }
+ }
+ unsigned char *save_the_location = var->data;
+ bool there_is_more = false;
+ unsigned char *outer_location = var->data;
+ do
+ {
+ var->data = outer_location;
+ switch( var->type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ {
+ cbl_figconst_t figconst = (cbl_figconst_t)(var->attr & FIGCONST_MASK);
+ figconst = normal_value_e;
+ char figconst_char;
+ switch(figconst)
+ {
+ case low_value_e:
+ figconst_char = low_value_character;
+ break;
+ case zero_value_e:
+ figconst_char = ascii_zero;
+ break;
+ case space_value_e:
+ figconst_char = ascii_space;
+ break;
+ case quote_value_e:
+ figconst_char = quote_character;
+ break;
+ case high_value_e:
+ figconst_char = high_value_character;
+ break;
+ default:
+ break;
+ }
+ if( figconst != normal_value_e)
+ {
+ figconst_char = ascii_to_internal(figconst_char);
+ memset( outer_location,
+ figconst_char,
+ capacity );
+ }
+ else
+ {
+ memset( outer_location,
+ internal_space,
+ capacity );
+
+ bool special = false;
+ char special_value;
+ if( strlen(var->initial) == 0 )
+ {
+ switch(var->initial[1])
+ {
+ case ascii_L:
+ special = true;
+ special_value = low_value_character;
+ break;
+ case ascii_Z:
+ special = true;
+ special_value = ascii_zero;
+ break;
+ case ascii_H:
+ special = true;
+ special_value = high_value_character;
+ break;
+ case ascii_Q:
+ special = true;
+ special_value = quote_character;
+ break;
+ }
+ if( special )
+ {
+ special_value = ascii_to_internal(special_value);
+ memset( outer_location,
+ special_value,
+ capacity );
+ }
+ }
+ else
+ {
+ memcpy( outer_location,
+ converted_initial,
+ strlen(converted_initial));
+ }
+ }
+ break;
+ }
+
+ case FldNumericEdited:
+ {
+ if( strlen(converted_initial) )
+ {
+ // What the programmer says the value is, the value becomes, no matter
+ // how wrong it might be.
+
+ if( (size_t)var->capacity <= strlen(converted_initial) )
+ {
+ memcpy(var->data, converted_initial, var->capacity);
+ }
+ else
+ {
+ size_t filler = (size_t)var->capacity - strlen(converted_initial);
+ if( var->attr & rjust_e )
+ {
+ memset(var->data, internal_space, filler);
+ memcpy( var->data + filler,
+ converted_initial,
+ strlen(converted_initial));
+ }
+ else
+ {
+ memset(var->data+strlen(converted_initial), internal_space, filler);
+ memcpy( var->data,
+ converted_initial,
+ strlen(converted_initial));
+ }
+ }
+ }
+ else
+ {
+ // A zero-length initialization string becomes zero:
+ char *zeroes = (char *)malloc(var->capacity);
+ memset(zeroes, internal_zero, var->capacity);
+ string_to_numeric_edited( (char *)var->data,
+ zeroes,
+ var->rdigits,
+ 0,
+ var->picture);
+ ascii_to_internal_str((char *)var->data, var->capacity);
+ free(zeroes);
+ }
+ break;
+ }
+
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldIndex:
+ case FldLiteral:
+ case FldLiteralN:
+ initialize_numeric(var, converted_initial);
+ break;
+
+ case FldAlphaEdited:
+ {
+ if( strlen(converted_initial) )
+ {
+ // Initialization doesn't go through the MOVE logic; you
+ // just cram in what you have.
+
+ size_t length = var->capacity;
+ if( length > strlen(converted_initial) )
+ {
+ length = strlen(converted_initial);
+ }
+ memcpy(outer_location, converted_initial, length);
+ if( length < (size_t)var->capacity )
+ {
+ memset( outer_location+length,
+ ascii_space,
+ var->capacity - length);
+ }
+ }
+ else
+ {
+ // In the absence of an initial value, assume all spaces:
+ char *spaces = (char *)malloc(var->capacity);
+ memset(spaces, internal_space, var->capacity);
+ __gg__string_to_alpha_edited(
+ (char *)var->data,
+ spaces,
+ var->capacity,
+ var->picture);
+ free(spaces);
+ }
+ break;
+ }
+
+ case FldClass:
+ // Do nothing for class
+ break;
+
+ case FldPointer:
+ memset(var->data, 0, var->capacity);
+ break;
+
+ default:
+ fprintf(stderr, "###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
+ fprintf(stderr, "###### You got yourself a new CVT_type %d\n",
+ var->type);
+ assert(false);
+ }
+
+ char *location = (char *)save_the_location;
+
+ there_is_more = false;
+ size_t i=0;
+ // Roll up through the dimensions like an odometer.
+ for(i=0; i<number_of_dimensions; i++)
+ {
+ if( ++dimension[i] < limits[i] )
+ {
+ break;
+ }
+ dimension[i] = 0;
+ }
+ if( i < number_of_dimensions )
+ {
+ there_is_more = there_can_be_more;
+ }
+ if( there_is_more )
+ {
+ // Augment location by the size of each dimension:
+ for(i=0; i<number_of_dimensions; i++)
+ {
+ location += dimension[i] * capacities[i];
+ }
+ }
+
+ outer_location = (unsigned char *)location;
+ } while(there_is_more);
+
+ var->data = save_the_location;
+
+ // See the comment up above about suppressing and restoring
+ // BLANK WHEN ZERO during initialization.
+ var->attr |= (save_the_attribute&blank_zero_e);
+
+ free(converted_initial);
+ }
+
+static void
+alpha_to_alpha_move(cblc_resolved_t &dest,
+ cblc_resolved_t &source )
+ {
+ // This is a helper function, called when it is known that both source
+ // and dest are alphanumeric
+ char *to = (char *)dest.location;
+ const char *from = (const char *)source.location;
+ size_t count = std::min(dest.length_untrimmed, source.length_trimmed);
+
+ size_t source_length = source.length_trimmed;
+ size_t dest_length = dest.length_untrimmed;
+
+ if( source_length >= dest_length )
+ {
+ // We have more source characters than places to put them
+ if( dest.field->attr & rjust_e )
+ {
+ // Destination is right-justified, so we
+ // discard the leading source characters:
+ memmove(to,
+ from + (source_length - count),
+ count);
+ }
+ else
+ {
+ // Destination is right-justified, so we
+ // discard the trailing source characters:
+ memmove(to,
+ from,
+ count);
+ }
+ }
+ else
+ {
+ // We have too few source characters to fill the destination.
+ if( dest.field->attr & rjust_e )
+ {
+ // The destination is right-justified
+ if( source.move_all )
+ {
+ // and the source is move_all. We will repeat the input until
+ // it fills the output, starting from the right side.
+ // Note the oddball termination condition, recalling that i
+ // and source.length are unsigned
+ size_t isource = source_length-1;
+ for(size_t i=dest_length-1; i<dest_length; i--)
+ {
+ to[i] = from[isource--];
+ if( isource >= source_length )
+ {
+ isource = source_length-1;
+ }
+ }
+ }
+ else
+ {
+ // The destination is right-justified, and the source is an
+ // ordinary string too short to fill it. So, we space-fill
+ // the leading characters.
+ // We do the move first, in case this is an overlapping move
+ // involving characters that will be space-filled
+ memmove(to + (dest_length-count),
+ from,
+ count);
+ memset(to, internal_space, dest_length-count);
+ }
+ }
+ else
+ {
+ // The source is smaller than the destination
+ // The destination is left-justified
+ if( source.move_all )
+ {
+ // and the source is move_all. We will repeat the input until
+ // it fills the output, starting from the left side.
+ size_t isource = 0;
+ for(size_t i=0; i<dest_length; i++)
+ {
+ to[i] = from[isource++];
+ if( isource >= source_length )
+ {
+ isource = 0;
+ }
+ }
+ }
+ else
+ {
+ // The destination is right-justified, and the source is an
+ // ordinary string too short to fill it. So, we space-fill
+ // the trailing characters.
+ // We do the move first, in case this is an overlapping move
+ // involving characters that will be space-filled
+ memmove(to,
+ from,
+ count);
+ memset( to + count,
+ internal_space,
+ dest_length-count);
+ }
+ }
+ }
+ }
+
+extern "C"
+void
+__gg__move( struct cblc_refer_t *dest_ref,
+ struct cblc_refer_t *source_ref,
+ rounded_t rounded )
+ {
+ cblc_resolved_t dest;
+ cblc_resolved_t source;
+
+ __gg__refer_resolve(dest_ref, &dest);
+ __gg__refer_resolve(source_ref, &source);
+
+ bool moved = true;
+
+ __int128 value;
+ int hyphen;
+ int rdigits;
+
+ size_t min_length;
+
+ cbl_figconst_t source_figconst = (cbl_figconst_t)(source.field->attr & FIGCONST_MASK);
+ char figconst_char = 0;
+
+ switch( dest.field->type )
+ {
+ case FldGroup:
+ switch( source.field->type )
+ {
+ case FldLiteral:
+ switch(source_figconst)
+ {
+ case low_value_e:
+ figconst_char = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e:
+ figconst_char = internal_zero;
+ break;
+ case space_value_e:
+ figconst_char = internal_space;
+ break;
+ case quote_value_e:
+ figconst_char = ascii_to_internal(quote_character);
+ break;
+ case high_value_e:
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ figconst_char = high_value_character;
+ }
+ else
+ {
+ figconst_char = ascii_to_internal(high_value_character);
+ }
+ break;
+ default:
+ break;
+ }
+ memset( dest.location,
+ figconst_char,
+ dest.length_untrimmed);
+ break;
+
+ case FldLiteralN:
+ {
+ // We are moving a literal to an FldGroup, so
+ // change the source location and length:
+ source.location = (unsigned char *)source.field->initial;
+ source.length_untrimmed = strlen(source.field->initial);
+ source.length_trimmed = strlen(source.field->initial);
+
+ // Special processing for figurative constants:
+ switch(source_figconst)
+ {
+ case low_value_e:
+ figconst_char = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e:
+ figconst_char = internal_zero;
+ break;
+ case space_value_e:
+ figconst_char = internal_space;
+ break;
+ case quote_value_e:
+ figconst_char = ascii_to_internal(quote_character);
+ break;
+ case high_value_e:
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ figconst_char = high_value_character;
+ }
+ else
+ {
+ figconst_char = ascii_to_internal(high_value_character);
+ }
+ break;
+ default:
+ break;
+ }
+ if(source_figconst)
+ {
+ // This is a figurative constant, so fill the
+ // destination with the correct byte value:
+ memset( dest.location,
+ figconst_char,
+ dest.length_untrimmed);
+ }
+ else
+ {
+ //This is a normal alpha-to-alpha move:
+ alpha_to_alpha_move(dest, source);
+ }
+ break;
+ }
+
+ // For all other types, we just do a straight byte-for-byte move
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldGroup:
+ // This is a little bold, but non-alphabetics will never
+ // have the rjust_e or MOVE_ALL bits on, so it's safe
+ // enough.
+ alpha_to_alpha_move(dest, source);
+ break;
+
+ default:
+ moved = false;
+ break;
+ }
+
+ break;
+
+ case FldAlphanumeric:
+ switch( source.field->type )
+ {
+ case FldGroup:
+ alpha_to_alpha_move(dest, source);
+ break;
+
+ case FldLiteral:
+ // We are moving one of these types to an alphanumeric
+ switch(source_figconst)
+ {
+ case low_value_e:
+ figconst_char = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e:
+ figconst_char = internal_zero;
+ break;
+ case space_value_e:
+ figconst_char = internal_space;
+ break;
+ case quote_value_e:
+ figconst_char = ascii_to_internal(quote_character);
+ break;
+ case high_value_e:
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ figconst_char = high_value_character;
+ }
+ else
+ {
+ figconst_char = ascii_to_internal(high_value_character);
+ }
+ break;
+ default:
+ break;
+ }
+ memset( dest.location,
+ figconst_char,
+ dest.length_untrimmed);
+ break;
+
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ // This is an ordinary alpha-to-alpha move:
+ alpha_to_alpha_move(dest, source);
+ break;
+
+ case FldNumericDisplay:
+ // We are moving a FldNumericDisplay to an alphanumeric:
+ if( source.field->rdigits > 0 )
+ {
+ fprintf(stderr, "%s() %s:%d -- It isn't legal to move a"
+ " non-integer NumericDisplay to an"
+ " alphanumeric\n",
+ __func__, __FILE__, __LINE__);
+ fprintf( stderr,
+ "%s to %s\n",
+ source.field->name,
+ dest.field->name);
+ exit(1);
+ }
+ else
+ {
+ // We are moving a integer NumericDisplay to an
+ // alphanumeric. We ignore any sign bit, and just
+ // move the characters:
+
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ size_t source_digits
+ = source.field->digits
+ + ( source.field->rdigits < 0
+ ? -source.field->rdigits : 0) ;
+
+ // Pick up the absolute value of the source
+ value = __gg__binary_value_from_resolved(&hyphen,
+ &rdigits,
+ &source);
+
+ char ach[128];
+
+ // Convert it to the full complement of digits available
+ // from the source...but no more
+ __gg__binary_to_string_internal(ach, source_digits, value);
+
+ if( !(dest.field->attr & rjust_e) )
+ {
+ min_length = std::min( source_digits,
+ dest.length_untrimmed);
+ memmove(dest.location, ach, min_length);
+ if( min_length < dest.length_untrimmed )
+ {
+ // min_length is smaller than dest_length, so we
+ // have to space-fill the excess bytes in the
+ // destination:
+ memset( dest.location + min_length,
+ internal_space,
+ dest.length_untrimmed - min_length );
+ }
+ }
+ else
+ {
+ // Destination is right-justified, so things are
+ // slightly more complex
+ if( (size_t)source.field->digits
+ >= dest.length_untrimmed )
+ {
+ // We need to truncate the source data on the
+ // left:
+ memmove(
+ dest.location,
+ ach + (source.field->digits
+ - dest.length_untrimmed),
+ dest.length_untrimmed );
+ }
+ else
+ {
+ // We need to move the shorty source string to
+ // the right side of the dest, and space-fill
+ // the prefix:
+ memmove(dest.location
+ + (dest.length_untrimmed
+ - source.field->digits),
+ ach,
+ source.field->digits );
+ memset( dest.location,
+ internal_space,
+ (dest.length_untrimmed
+ - source.field->digits));
+ }
+ }
+ }
+ break;
+
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ // We are moving a binary number to an alphanumeric:
+ if( source.field->rdigits > 0 )
+ {
+ fprintf(stderr, "%s() %s:%d -- It isn't legal to move a"
+ " non-integer binary number to an"
+ " alphanumeric\n",
+ __func__, __FILE__, __LINE__);
+ fprintf(stderr, "%s to %s\n", source.field->name, dest.field->name);
+ exit(1);
+ }
+ else
+ {
+ char ach[128];
+
+ // Turn the integer source into a value:
+ value = __gg__binary_value_from_resolved(&hyphen,
+ &rdigits,
+ &source);
+
+ source.length_untrimmed = source.field->digits;
+ source.length_trimmed = source.field->digits;
+
+ // Turn the integer value into a string:
+ __gg__binary_to_string_internal(ach,
+ source.length_untrimmed,
+ value);
+
+ char *pach = ach;
+
+ // When source is a temporary variable, it was set to
+ // a large number of digits, which will give the wrong
+ // result. So, we will make like the US Marine Corp,
+ // and improvise, adapt, and overcome.
+
+ // Specifically, we'll move pach to point to the first
+ // character that isn't zero.
+
+ if( source.field->attr & intermediate_e )
+ {
+ for(;;)
+ {
+ if( *(pach+1) == '\0' )
+ {
+ break;
+ }
+ if( ((*pach)&0xFF) != internal_zero )
+ {
+ break;
+ }
+ pach += 1;
+ source.length_untrimmed -= 1;
+ source.length_trimmed -= 1;
+ }
+ }
+
+ if( !(dest.field->attr & rjust_e) )
+ {
+ min_length = std::min( source.length_untrimmed,
+ dest.length_untrimmed);
+ memmove(dest.location, pach, min_length);
+ if( min_length < dest.length_untrimmed )
+ {
+ // min_length is smaller than dest_length, so we have to
+ // space-fill the excess bytes in the destination:
+ memset( dest.location + min_length,
+ internal_space,
+ dest.length_untrimmed - min_length );
+ }
+ }
+ else
+ {
+ // Destination is right-justified, so things are slightly more complex
+ if( source.length_untrimmed >= dest.length_untrimmed )
+ {
+ // We need to truncate the source data on the left:
+ memmove(dest.location,
+ pach + (source.length_untrimmed - dest.length_untrimmed),
+ dest.length_untrimmed );
+ }
+ else
+ {
+ // We need to move the shorty source string to the
+ // right side of the dest, and space-fill the prefix:
+ memmove(dest.location + (dest.length_untrimmed - source.length_untrimmed),
+ pach,
+ source.length_untrimmed );
+ memset(dest.location, internal_space, (dest.length_untrimmed - source.length_untrimmed));
+ }
+ }
+ }
+ break;
+
+ default:
+ moved = false;
+ break;
+ }
+
+ break;
+
+ case FldNumericBinary:
+ case FldNumericBin4:
+ switch( source.field->type )
+ {
+ case FldGroup:
+ min_length = std::min(source.length_trimmed, dest.length_untrimmed);
+ memmove(dest.location, source.location, min_length);
+ if( min_length < dest.length_untrimmed )
+ {
+ // min_length is smaller than dest_length, so we have to
+ // space-fill the excess bytes in the destination:
+ memset( dest.location + min_length,
+ internal_space,
+ dest.length_untrimmed - min_length );
+ }
+ dest.field->attr &= ~FIGCONST_MASK;
+ break;
+
+ case FldLiteral:
+ case FldAlphanumeric:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ {
+ // We are moving a number to a number:
+ value = __gg__binary_value_from_resolved(&hyphen, &rdigits, &source);
+
+ if( truncation_mode == trunc_std_e )
+ {
+ if( value < 0 )
+ {
+ value = -value;
+ value %= __gg__power_of_ten(dest.field->digits);
+ value = -value;
+ }
+ else
+ {
+ value %= __gg__power_of_ten(dest.field->digits);
+ }
+ }
+
+ __gg__scale_to_resolved( &dest,
+ value,
+ rdigits,
+ rounded,
+ NULL );
+
+ break;
+ }
+ default:
+ moved = false;
+ break;
+ }
+ break;
+
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBin5:
+ case FldIndex:
+ // Bin5 and Index are treated with no truncation, as if they were
+ // trunc_bin_e. The other types aren't subject to truncation.
+ switch( source.field->type )
+ {
+ case FldGroup:
+ min_length = std::min(source.length_trimmed, dest.length_untrimmed);
+ memmove(dest.location, source.location, min_length);
+ if( min_length < dest.length_untrimmed )
+ {
+ // min_length is smaller than dest_length, so we have to
+ // space-fill the excess bytes in the destination:
+ memset( dest.location + min_length,
+ internal_space,
+ dest.length_untrimmed - min_length );
+ }
+ break;
+
+ case FldLiteral:
+ case FldLiteralA:
+ case FldAlphanumeric:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ {
+ // We are moving a number to a number:
+ value = __gg__binary_value_from_resolved(&hyphen, &rdigits, &source);
+ __gg__scale_to_resolved( &dest,
+ value,
+ rdigits,
+ rounded,
+ NULL );
+ break;
+ }
+ default:
+ moved = false;
+ break;
+ }
+ break;
+
+ case FldAlphaEdited:
+ {
+ switch( source.field->type )
+ {
+ case FldGroup:
+ min_length = std::min(source.length_trimmed, dest.length_untrimmed);
+ memmove(dest.location, source.location, min_length);
+ if( min_length < dest.length_untrimmed )
+ {
+ // min_length is smaller than dest_length, so we have to
+ // space-fill the excess bytes in the destination:
+ memset( dest.location + min_length,
+ internal_space,
+ dest.length_untrimmed - min_length );
+ }
+ break;
+
+ case FldNumericDisplay:
+ {
+ int hyphen;
+ int rdigits;
+ __int128 value;
+
+ int source_digits = source.field->digits + (source.field->rdigits<0 ? -source.field->rdigits : 0) ;
+
+ // Pick up the absolute value of the source
+ value = __gg__binary_value_from_resolved(&hyphen, &rdigits, &source);
+
+ char ach[64];
+
+ // Convert it to the full complement of digits available
+ // from the source...but no more
+ __gg__binary_to_string(ach, source_digits, value);
+
+ // And move them into place:
+ __gg__string_to_alpha_edited( (char *)dest.location,
+ ach,
+ source_digits,
+ dest.field->picture);
+ break;
+ }
+
+
+ default:
+ {
+ char *display_string;
+ size_t display_string_length = dest.length_untrimmed;
+ if( source_figconst == low_value_e )
+ {
+ display_string = (char *)malloc(dest.length_untrimmed);
+ memset(display_string, ascii_to_internal(low_value_character), dest.length_untrimmed);
+ }
+ else if( source_figconst == zero_value_e )
+ {
+ display_string = (char *)malloc(dest.length_untrimmed);
+ memset(display_string, internal_zero, dest.length_untrimmed);
+ }
+ else if( source_figconst == space_value_e )
+ {
+ display_string = (char *)malloc(dest.length_untrimmed);
+ memset(display_string, internal_space, dest.length_untrimmed);
+ }
+ else if( source_figconst == quote_value_e )
+ {
+ display_string = (char *)malloc(dest.length_untrimmed);
+ memset(display_string, ascii_to_internal(quote_character), dest.length_untrimmed);
+ }
+ else if( source_figconst == high_value_e )
+ {
+ display_string = (char *)malloc(dest.length_untrimmed);
+ memset(display_string, ascii_to_internal(high_value_character), dest.length_untrimmed);
+ }
+ else
+ {
+ display_string = format_for_display_internal(source.field,
+ (unsigned char *)source.location,
+ source.length_untrimmed);
+ display_string_length = strlen(display_string);
+ }
+ __gg__string_to_alpha_edited( (char *)dest.location,
+ display_string,
+ display_string_length,
+ dest.field->picture);
+ free(display_string);
+ break;
+ }
+ }
+ break;
+ }
+
+ default:
+ moved = false;
+ break;
+ }
+ if( !moved )
+ {
+ fprintf(stderr, "%s() %s:%d -- We were unable to do a move from "
+ "type %d to %d\n",
+ __func__, __FILE__, __LINE__,
+ source.field->type, dest.field->type);
+ exit(1);
+ }
+ }
+
+extern "C"
+void
+__gg__file_sort_ff_input( cblc_file_t *workfile,
+ cblc_file_t *input,
+ cblc_field_t *sd_record)
+ {
+ // The name means "file-file input"
+
+ // We are going to read records from input according to sd_record, and
+ // write them in normalized form (that is, all the same length with no
+ // separators) to workfile
+
+ for(;;)
+ {
+ file_read_into_field( input,
+ sd_record );
+ if( input->io_status >= FhNotOkay )
+ {
+ break;
+ }
+ // We have the data we need in sd_record. Transmit it to workfile.
+ __gg__file_write( workfile,
+ sd_record,
+ sd_record->data,
+ sd_record->capacity,
+ 0,
+ 0);
+ }
+ }
+
+extern "C"
+void
+__gg__file_sort_ff_output( cblc_file_t *output,
+ cblc_file_t *workfile,
+ cblc_field_t *sd_record)
+ {
+ // The name means "file-file output"
+
+ // We read records from workfile and write them to the output file
+
+ // First, rewind the input data file:
+ fseek(workfile->file_pointer, 0, SEEK_SET);
+ for(;;)
+ {
+ file_read_into_field( workfile,
+ sd_record );
+ if( workfile->io_status >= FhNotOkay )
+ {
+ break;
+ }
+ __gg__file_write( output,
+ sd_record,
+ sd_record->data,
+ sd_record->capacity,
+ 0,
+ 1); // Data followed by one newline
+ }
+ }
+
+extern "C"
+void
+__gg__sort_workfile(char *workfile,
+ cblc_field_t *sd_record,
+ size_t nkeys,
+ cblc_field_t **keys,
+ int *ascending,
+ int duplicates)
+ {
+ // The unsorted data is in workfile. We will create a memory map of that
+ // file, and sort that map:
+
+ char *filename = internal_to_console(workfile,strlen(workfile));
+
+ int fd = open(filename, O_RDWR);
+ if( fd <= 0 )
+ {
+ __gg__handle_error(__func__, "Failed to open filename");
+ }
+ else
+ {
+ struct stat sb;
+ if (fstat(fd, &sb) == -1) /* To obtain file size */
+ {
+ __gg__handle_error(__func__, "Couldn't fstate filename");
+ }
+ else
+ {
+ unsigned char *mapped_data =
+ (unsigned char *)mmap( NULL, // Kernel chooses address
+ sb.st_size, // File size
+ PROT_READ|PROT_WRITE,
+ MAP_SHARED, // Carry changes to underlying file
+ fd, // This be the file
+ 0); // No offset
+ if( mapped_data == MAP_FAILED )
+ {
+ __gg__handle_error(__func__, "mmap failed");
+ }
+ else
+ {
+ // We have a good map of the workfile.
+
+ // We wrote the SORT TABLE code first, and that works. So,
+ // our goal here is to make the mapped_data look like a table!
+
+ // Let's live dangerously. We will modify the data locations
+ // of sd_record and the keys in place, and we'll put them back
+ // later:
+
+ unsigned char *sd_location = sd_record->data;
+
+ unsigned char **key_locations = (unsigned char **)malloc(nkeys * sizeof(unsigned char *));
+ for(size_t i=0; i<nkeys; i++)
+ {
+ key_locations[i] = keys[i]->data;
+ }
+
+ // Now make the changes so that sd_record looks like a table we
+ // want to sort:
+
+ sd_record->data = mapped_data;
+ sd_record->occurs_lower = sd_record->occurs_upper = sb.st_size / sd_record->capacity;
+
+ for(size_t i=0; i<nkeys; i++)
+ {
+ keys[i]->data = mapped_data + keys[i]->offset;
+ }
+
+ cblc_refer_t wrapper = {};
+ wrapper.field = sd_record;
+
+ __gg__sort_table( &wrapper,
+ sb.st_size / sd_record->capacity,
+ nkeys,
+ keys,
+ ascending,
+ duplicates);
+
+ // We are done with the modified fields, so we put back the
+ // original data:
+
+ sd_record->data = sd_location;
+ for(size_t i=0; i<nkeys; i++)
+ {
+ keys[i]->data = key_locations[i];
+ }
+ free(key_locations);
+
+ // make sure our changes are written back
+ msync(mapped_data, sb.st_size, MS_SYNC);
+ munmap(mapped_data, sb.st_size);
+ }
+ }
+ close(fd);
+ }
+ free(filename);
+ }
+
+static int
+compare_for_merge(const void *e1, const void *e2, void *sorter_)
+ {
+ int retval = 0;
+ struct for_sort_table *sorter = (struct for_sort_table *)sorter_;
+
+ assert( (const unsigned char *)e1 >= sorter->bottom );
+ assert( (const unsigned char *)e2 >= sorter->bottom );
+ assert( (const unsigned char *)e1 < sorter->top );
+ assert( (const unsigned char *)e2 < sorter->top );
+
+ cblc_refer_t left_ref = {};
+ cblc_refer_t right_ref = {};
+
+ left_ref.field = sorter->left_side;
+ right_ref.field = sorter->right_side;
+
+ for(size_t i=0; i<sorter->nkeys; i++)
+ {
+ // e1 and e2 each point to an entire row of the table.
+
+ // For each key, we need to pull out the relevant piece of the row
+ // that is the actual key:
+
+ const unsigned char *key1;
+ const unsigned char *key2;
+ if( sorter->ascending[i] )
+ {
+ key1 = (const unsigned char *)e1 + sorter->left_side[i].offset;
+ // Note that left_side and right_side have the same offset
+ key2 = (const unsigned char *)e2 + sorter->left_side[i].offset;
+ }
+ else
+ {
+ // We accomplish a descending sort by swapping the data sources
+ key1 = (const unsigned char *)e2 + sorter->left_side[i].offset;
+ key2 = (const unsigned char *)e1 + sorter->left_side[i].offset;
+ }
+ memcpy(sorter->left_side[i].data, key1, sorter->left_side[i].capacity);
+ memcpy(sorter->right_side[i].data, key2, sorter->right_side[i].capacity);
+
+ retval = __gg__compare(&left_ref, &right_ref, 0);
+ }
+
+ return retval;
+ }
+
+
+extern "C"
+void __gg__merge_files( char *workfile,
+ size_t nkeys,
+ cblc_field_t **keys,
+ int *ascending,
+ size_t ninputs,
+ cblc_file_t **inputs,
+ cblc_field_t **fd_records)
+ {
+ // First, we are going to set up the sorter object that controls how the
+ // comparison takes place:
+
+ enum
+ {
+ flag_exhausted,
+ flag_ready,
+ flag_need_to_read,
+ };
+
+ struct for_sort_table sorter;
+
+ sorter.left_side = (cblc_field_t *)malloc(nkeys * sizeof(cblc_field_t));
+ sorter.right_side = (cblc_field_t *)malloc(nkeys * sizeof(cblc_field_t));
+
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ // Establish the left_side:
+ // Copy over the basic structure
+ memcpy(&sorter.left_side[i], keys[i], sizeof(cblc_field_t) );
+ // With everything else in place, adjust the allocated data:
+ sorter.left_side[i].data = (unsigned char *)malloc(sorter.left_side[i].capacity);
+
+ // Establish the right_side:
+ // Copy over the basic structure
+ memcpy(&sorter.right_side[i], keys[i], sizeof(cblc_field_t) );
+ // With everything else in place, adjust the allocated data:
+ sorter.right_side[i].data = (unsigned char *)malloc(sorter.right_side[i].capacity);
+ }
+
+ sorter.nkeys = nkeys;
+ sorter.ascending = ascending;
+
+ // Make sure that the bottom/top tests never fail:
+ sorter.bottom = NULL;
+ sorter.top = (unsigned char *)(-1L);
+
+ // We have the sorter ready to make comparisons.
+
+ // Let's open the output file first:
+
+ char *filename = internal_to_console(workfile,strlen(workfile));
+ FILE *fworkfile = fopen(filename, "w");
+ if( !fworkfile )
+ {
+ __gg__handle_error(__func__, "Couldn't open filename for output\n");
+ }
+ else
+ {
+ // We need to open the various input files:
+ for(size_t i=0; i<ninputs; i++)
+ {
+ __gg__file_open(inputs[i], ascii_r, true);
+ if( inputs[i]->io_status >= FhNotOkay )
+ {
+ inputs[i]->file_pointer = NULL;
+ }
+ }
+
+ // All of the files are open.
+
+ // We use an array of byte flags.
+ char *flags = (char *)malloc(ninputs);
+ memset(flags, flag_need_to_read, ninputs);
+
+ for(;;)
+ {
+ // We are going to loop until all input files have been exhausted.
+
+ // It is time to scan all the input files. We look for the "best" of
+ // of the
+ int the_winner = -1;
+
+ for(size_t i=0; i<ninputs; i++)
+ {
+ if( flags[i] == flag_need_to_read )
+ {
+ // It is time to read a record from this file:
+ file_read_into_field( inputs[i],
+ fd_records[i]);
+ if( inputs[i]->io_status >= FhNotOkay )
+ {
+ // We have exhausted this file:
+ flags[i] = 0;
+ __gg__file_close(inputs[i]);
+ }
+ else
+ {
+ flags[i] = flag_ready;
+ }
+ }
+
+ if( flags[i] == flag_exhausted )
+ {
+ // This file has been exhausted, and is of no use to us.
+ continue;
+ }
+ if( the_winner == -1 )
+ {
+ // We'll presume that this input is the best of the lot
+ the_winner = i;
+ continue;
+ }
+ // At this point, we have a presumptive winner of the scan.
+ // we can now check [i] versus [the_winner].
+
+ int compare_result = compare_for_merge( fd_records[i]->data,
+ fd_records[the_winner]->data,
+ &sorter);
+ if( compare_result < 0 )
+ {
+ // We have a new winner:
+ the_winner = i;
+ }
+ }
+ // We have compared the top records of the input files, and selected
+ // a winner:
+ if( the_winner == -1 )
+ {
+ // We have exhausted all of the input files. Time to leave.
+ break;
+ }
+ // It is at this point we write out the winner to the workfile:
+ fwrite( fd_records[the_winner]->data,
+ fd_records[the_winner]->capacity,
+ 1,
+ fworkfile);
+ // We now flag this file as needing to be read:
+ flags[the_winner] = flag_need_to_read;
+ }
+ free(flags);
+ fclose(fworkfile);
+ }
+ free(filename);
+ free(sorter.left_side);
+ free(sorter.right_side);
+ }
+
+static const char *
+funky_find( const char *piece,
+ const char *piece_end,
+ const char *whole,
+ const char *whole_end )
+ {
+ const char *retval = NULL;
+
+ size_t length_of_piece = piece_end - piece;
+ assert(length_of_piece);
+
+ whole_end -= length_of_piece;
+
+ while( whole <= whole_end )
+ {
+ if( memcmp( piece, whole, length_of_piece) == 0 )
+ {
+ retval = whole;
+ break;
+ }
+ whole += 1;
+ }
+ return retval;
+ }
+
+typedef struct normalized_operand
+ {
+ // These are the characters of the string. When the field is NumericDisplay
+ // any leading or trailing +/- characters are removed, and any embedded
+ // NUMERIC_DISPLAY_SIGN_BIT bits are removed.
+ std::string the_characters;
+ size_t offset; // Usually zero. One when there is a leading sign.
+ size_t length; // Usually the same as the original. But it is one less
+ // // than the original when there is a trailing sign.
+ } normalized_operand;
+
+typedef struct comparand
+ {
+ size_t id_2_index;
+ cbl_inspect_bound_t operation;
+ normalized_operand identifier_3; // The thing to be found
+ normalized_operand identifier_5; // The replacement, for FORMAT 2
+ const char *alpha; // The start location within normalized_id_1
+ const char *omega; // The end+1 location within normalized_id_1
+ bool leading;
+ bool first;
+ } comparand;
+
+typedef struct id_2_result
+ {
+ cblc_resolved_t identifier_2;
+ size_t result;
+ }id_2_result;
+
+static normalized_operand
+normalize_id(const cblc_resolved_t &refer)
+ {
+ normalized_operand retval;
+
+ if( refer.field )
+ {
+ cbl_figconst_t figconst
+ = (cbl_figconst_t)(refer.field->attr & FIGCONST_MASK);
+
+ retval.offset = 0;
+ retval.length = refer.length_trimmed;
+
+ if( refer.field->type == FldNumericDisplay )
+ {
+ // The value is NumericDisplay.
+ if( refer.field->attr & separate_e )
+ {
+ // Because the sign is a separate plus or minus, the length
+ // gets reduced by one:
+ retval.length = refer.length_untrimmed - 1;
+ if( refer.field->attr & leading_e )
+ {
+ // Because the sign character is LEADING, we increase the
+ // offset by one
+ retval.offset = 1;
+ }
+ }
+ for( size_t i=retval.offset; i<retval.length; i++ )
+ {
+ // Because we are dealing with a NumericDisplay that might have
+ // the NUMERIC_DISPLAY_SIGN_BIT turned on, we need to mask it off
+ unsigned char ch = refer.location[i];
+ turn_sign_bit_off(&ch);
+ retval.the_characters = ch;
+ }
+ }
+ else
+ {
+ // We are set up to create the_characters;
+ if( figconst == normal_value_e )
+ {
+ for( size_t i=retval.offset; i<retval.length; i++ )
+ {
+ retval.the_characters += refer.location[i];
+ }
+ }
+ else
+ {
+ char ch=0;
+ switch( figconst )
+ {
+ case low_value_e :
+ ch = ascii_to_internal(low_value_character);
+ break;
+ case zero_value_e :
+ ch = internal_zero;
+ break;
+ case space_value_e :
+ ch = internal_space;
+ break;
+ case quote_value_e :
+ ch = ascii_to_internal(quote_character);
+ break;
+ case high_value_e :
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ ch = high_value_character;
+ }
+ else
+ {
+ ch = ascii_to_internal(high_value_character);
+ }
+ break;
+ case normal_value_e:
+ // We can't get here
+ break;
+ }
+ for( size_t i=retval.offset; i<retval.length; i++ )
+ {
+ retval.the_characters += ch;
+ }
+ }
+ }
+ }
+ else
+ {
+ // THere is no field, so leave the_characters empty.
+ retval.offset = 0;
+ retval.length = 0;
+ }
+ return retval;
+ }
+
+static void
+match_lengths( normalized_operand &id_target,
+ const normalized_operand &id_source)
+ {
+ char ch = id_target.the_characters[0];
+ id_target.the_characters.clear();
+ for(size_t i=0; i<id_source.length; i++)
+ {
+ id_target.the_characters += ch;
+ }
+ id_target.length = id_source.length;
+ }
+
+static void
+the_alpha_and_omega(const normalized_operand &id_before,
+ const normalized_operand &id_after,
+ const char * &alpha,
+ const char * &omega)
+ {
+ // First, we see if omega needs to be reduced because we find the id_before
+ // value between alpha and omega.
+ if( id_before.length )
+ {
+ // There is an end-string to look for:
+
+ const char *start = id_before.the_characters.c_str();
+ const char *end = start + id_before.length;
+ const char *found = funky_find(start, end, alpha, omega);
+ if( found )
+ {
+ // We found id_before within alpha/omega, so reduce omega
+ // to the found location.
+ omega = found;
+ }
+ }
+
+ // We now look between alpha and the possibly new omega for id_after:
+ if( id_after.length )
+ {
+ const char *start = id_after.the_characters.c_str();
+ const char *end = start + id_after.length;
+ const char *found = funky_find(start, end, alpha, omega);
+ if( found )
+ {
+ // We found id_after in the alpha/omega segment. We update alpha
+ // be the character after the id_after substring.
+ alpha = found + (end-start);
+ }
+ else
+ {
+ // We didn't find the id_after string, so we set the alpha to be
+ // omega. That means that no tally or replace operation will take
+ // because no characters will qualify.
+ alpha = omega;
+ }
+ }
+ }
+
+extern "C"
+void
+__gg__inspect_format_1( size_t *integers,
+ cblc_refer_t *refers)
+ {
+ size_t int_index = 0;
+ size_t cblc_index = 0;
+
+ // Reference the language specification for the meanings of identifier_X
+
+ // Pick up the number of identifier_2 loops in this INSPECT statement
+ size_t n_identifier_2 = integers[int_index++];
+
+ std::vector<id_2_result> id_2_results(n_identifier_2);
+
+ // Pick up identifier_1, which is the string being inspected
+ cblc_resolved_t identifier_1;
+ __gg__refer_resolve(&refers[cblc_index++], &identifier_1);
+
+ // normalize it, according to the language specification.
+ normalized_operand normalized_id_1 = normalize_id(identifier_1);
+
+ std::vector<comparand> comparands;
+
+ for(size_t i=0; i<n_identifier_2; i++)
+ {
+ // For each identifier_2, we pick up its value:
+ cblc_resolved_t identifier_2;
+ __gg__refer_resolve(&refers[cblc_index++], &identifier_2);
+
+ id_2_results[i].identifier_2 = identifier_2;
+ id_2_results[i].result = 0;
+
+ // For each identifier 2, there is a count of operations:
+ size_t nbounds = integers[int_index++];
+
+ for(size_t j=0; j<nbounds; j++ )
+ {
+ // each operation has a bound code:
+ cbl_inspect_bound_t operation
+ = (cbl_inspect_bound_t)integers[int_index++];
+ switch( operation )
+ {
+ case bound_characters_e:
+ {
+ // We are counting characters. There is no identifier-3,
+ // but we we hard-code the length to one to represent a
+ // single character.
+ comparand next_comparand;
+ next_comparand.id_2_index = i;
+ next_comparand.operation = operation;
+ next_comparand.identifier_3.length = 1;
+
+ cblc_resolved_t identifier_4_before;
+ cblc_resolved_t identifier_4_after;
+
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_before);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_after);
+
+ normalized_operand normalized_id_4_before
+ = normalize_id(identifier_4_before);
+ normalized_operand normalized_id_4_after
+ = normalize_id(identifier_4_after);
+
+ next_comparand.alpha
+ = normalized_id_1.the_characters.c_str();
+ next_comparand.omega
+ = next_comparand.alpha + normalized_id_1.length;
+
+ the_alpha_and_omega(normalized_id_4_before,
+ normalized_id_4_after,
+ next_comparand.alpha,
+ next_comparand.omega);
+ comparands.push_back(next_comparand);
+ break;
+ }
+ default:
+ {
+ // We have some number of identifer-3 values,
+ // each with possible PHRASE1 modifiers.
+ size_t pair_count = integers[int_index++];
+
+ // We need to build up pair_count comparand structures:
+
+ for(size_t k=0; k<pair_count; k++)
+ {
+ comparand next_comparand;
+ next_comparand.id_2_index = i;
+ next_comparand.operation = operation;
+
+ cblc_resolved_t identifier_3_r;
+ cblc_resolved_t identifier_4_before;
+ cblc_resolved_t identifier_4_after;
+
+ __gg__refer_resolve(&refers[cblc_index++], &identifier_3_r);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_before);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_after);
+
+ next_comparand.identifier_3 = normalize_id(identifier_3_r);
+ next_comparand.alpha
+ = normalized_id_1.the_characters.c_str();
+ next_comparand.omega
+ = next_comparand.alpha + normalized_id_1.length;
+
+ normalized_operand normalized_id_4_before
+ = normalize_id(identifier_4_before);
+ normalized_operand normalized_id_4_after
+ = normalize_id(identifier_4_after);
+
+ the_alpha_and_omega(normalized_id_4_before,
+ normalized_id_4_after,
+ next_comparand.alpha,
+ next_comparand.omega);
+ next_comparand.leading = true;
+ comparands.push_back(next_comparand);
+ }
+ }
+ }
+ }
+ }
+
+ // We are now ready to walk through identifier-1, character by
+ // character, checking each of the comparands for a match:
+
+ // We are now set up to accomplish the data flow described
+ // in the language specification. We loop through the
+ // the character positions in normalized_id_1:
+ const char *leftmost
+ = normalized_id_1.the_characters.c_str();
+ const char *rightmost
+ = leftmost + normalized_id_1.length;
+
+ while( leftmost < rightmost )
+ {
+ // For each leftmost position, we check each of the
+ // pairs:
+
+ for(size_t k=0; k<comparands.size(); k++)
+ {
+ if( leftmost < comparands[k].alpha )
+ {
+ // This can't be a match, because leftmost is
+ // to the left of the comparand's alpha.
+ continue;
+ }
+ if( leftmost + comparands[k].identifier_3.length
+ > comparands[k].omega )
+ {
+ // This can't be a match, because the rightmost
+ // character of the comparand falls to the right
+ // of the comparand's omega
+ continue;
+ }
+ // A match is theoretically possible, because all
+ // the characters of the comparand fall between
+ // alpha and omega:
+ bool possible_match = true;
+
+ if( comparands[k].operation != bound_characters_e )
+ {
+ for(size_t m=0; m<comparands[k].identifier_3.length; m++)
+ {
+ if( comparands[k].identifier_3.the_characters[m]
+ != leftmost[m] )
+ {
+ possible_match = false;
+ break;
+ }
+ }
+ }
+ if( possible_match )
+ {
+ // The characters of the comparand match the
+ // characters at leftmost.
+ bool match = false;
+ switch( comparands[k].operation )
+ {
+ case bound_first_e:
+ // This can't happen in a FORMAT_1
+ warnx("The compiler goofed: "
+ "INSPECT FORMAT 1 "
+ "shouldn't have "
+ "bound_first_e");
+ exit(1);
+ break;
+
+ case bound_characters_e:
+ match = 1;
+ break;
+
+ case bound_all_e:
+ {
+ // We have a match.
+ match = true;
+ break;
+ }
+
+ case bound_leading_e:
+ {
+ // We have a match at leftmost.
+ if( comparands[k].leading )
+ {
+ match = true;
+ }
+ break;
+ }
+ }
+ if( match )
+ {
+ // We have a match at leftmost:
+
+ // Bump the result counter
+ id_2_results[comparands[k].id_2_index].result += 1;
+
+ // Adjust the leftmost pointer to point to
+ // the rightmost character of the matched
+ // string, keeping in mind that it will be
+ // bumped again after we break out of the
+ // k<pair_count loop:
+ leftmost
+ += comparands[k].identifier_3.length - 1;
+ break;
+ }
+ }
+ else
+ {
+ // We are within alpha/omega, but there was no
+ // match, which permanently disqualifies the
+ // possibility of LEADING
+ comparands[k].leading = false;
+ }
+ }
+ leftmost += 1;
+ }
+
+ // Add our results to the identifier_2 values:
+
+
+ for(size_t i = 0; i<id_2_results.size(); i++)
+ {
+ int hyphen;
+ int rdigits;
+ __int128 id_2_value
+ = __gg__binary_value_from_resolved(&hyphen,
+ &rdigits,
+ &id_2_results[i].identifier_2);
+ while(rdigits--)
+ {
+ id_2_value /= 10.0;
+ }
+
+ // Accumulate what we've found into it
+ id_2_value += id_2_results[i].result;
+
+ // And put it back:
+ __gg__scale_to_resolved( &id_2_results[i].identifier_2,
+ id_2_value,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+ }
+
+extern "C"
+void
+__gg__inspect_format_2( size_t *integers,
+ cblc_refer_t *refers)
+ {
+ size_t int_index = 0;
+ size_t cblc_index = 0;
+
+ // Reference the language specification for the meanings of identifier_X
+
+ // Pick up identifier_1, which is the string being inspected
+ cblc_resolved_t identifier_1;
+ __gg__refer_resolve(&refers[cblc_index++], &identifier_1);
+
+ // normalize it, according to the language specification.
+ normalized_operand normalized_id_1 = normalize_id(identifier_1);
+
+ std::vector<comparand> comparands;
+
+ // Pick up the count of operations:
+ size_t nbounds = integers[int_index++];
+
+ for(size_t j=0; j<nbounds; j++ )
+ {
+ // each operation has a bound code:
+ cbl_inspect_bound_t operation
+ = (cbl_inspect_bound_t)integers[int_index++];
+ switch( operation )
+ {
+ case bound_characters_e:
+ {
+ comparand next_comparand;
+ next_comparand.operation = operation;
+
+ cblc_resolved_t identifier_5;
+ cblc_resolved_t identifier_4_before;
+ cblc_resolved_t identifier_4_after;
+
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_5);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_before);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_after);
+
+ next_comparand.identifier_5
+ = normalize_id(identifier_5);
+ normalized_operand normalized_id_4_before
+ = normalize_id(identifier_4_before);
+ normalized_operand normalized_id_4_after
+ = normalize_id(identifier_4_after);
+
+ // Because this is a CHARACTER operation, the lengths of
+ // identifier-3 and identifier-5 should be one. Let's avoid the
+ // chaos that will otherwise ensue should the lengths *not* be
+ // one.
+ next_comparand.identifier_3.length = 1;
+ next_comparand.identifier_5.length = 1;
+
+ next_comparand.alpha = normalized_id_1.the_characters.c_str();
+ next_comparand.omega
+ = next_comparand.alpha + normalized_id_1.length;
+
+ the_alpha_and_omega(normalized_id_4_before,
+ normalized_id_4_after,
+ next_comparand.alpha,
+ next_comparand.omega);
+ comparands.push_back(next_comparand);
+ break;
+ }
+ default:
+ {
+ // We have some number of identifer-3/identifier-5 pairs,
+ // each with possible PHRASE1 modifiers.
+ size_t pair_count = integers[int_index++];
+
+ for(size_t k=0; k<pair_count; k++)
+ {
+ comparand next_comparand;
+ next_comparand.operation = operation;
+
+ cblc_resolved_t identifier_3_r;
+ cblc_resolved_t identifier_5_r;
+ cblc_resolved_t identifier_4_before;
+ cblc_resolved_t identifier_4_after;
+
+ __gg__refer_resolve(&refers[cblc_index++], &identifier_3_r);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_5_r);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_before);
+ __gg__refer_resolve(&refers[cblc_index++],
+ &identifier_4_after);
+
+ next_comparand.identifier_3 = normalize_id(identifier_3_r);
+ next_comparand.identifier_5 = normalize_id(identifier_5_r);
+
+ // Identifiers 3 and 5 have to be the same length. But
+ // but either, or both, can be figurative constants. If
+ // they are figurative constants, they start off with a
+ // length of one. We will expand figurative constants to
+ // match the length of the other one:
+
+ if( identifier_3_r.field->attr & FIGCONST_MASK )
+ {
+ match_lengths( next_comparand.identifier_3,
+ next_comparand.identifier_5);
+ }
+ else if( identifier_5_r.field->attr & FIGCONST_MASK )
+ {
+ match_lengths( next_comparand.identifier_5,
+ next_comparand.identifier_3);
+ }
+
+ next_comparand.alpha
+ = normalized_id_1.the_characters.c_str();
+ next_comparand.omega
+ = next_comparand.alpha + normalized_id_1.length;
+
+ normalized_operand normalized_id_4_before
+ = normalize_id(identifier_4_before);
+ normalized_operand normalized_id_4_after
+ = normalize_id(identifier_4_after);
+
+ the_alpha_and_omega(normalized_id_4_before,
+ normalized_id_4_after,
+ next_comparand.alpha,
+ next_comparand.omega);
+ next_comparand.leading = true;
+ next_comparand.first = true;
+ comparands.push_back(next_comparand);
+ }
+ }
+ }
+ }
+
+ // We are now set up to accomplish the data flow described
+ // in the language specification. We loop through the
+ // the character positions in normalized_id_1:
+ const char *leftmost
+ = normalized_id_1.the_characters.c_str();
+ const char *rightmost
+ = leftmost + normalized_id_1.length;
+
+ while( leftmost < rightmost )
+ {
+ // For each leftmost position, we check each of the
+ // comparands
+
+ for(size_t k=0; k<comparands.size(); k++)
+ {
+ if( leftmost < comparands[k].alpha )
+ {
+ // This can't be a match, because leftmost is
+ // to the left of the comparand's alpha.
+ continue;
+ }
+ if( leftmost + comparands[k].identifier_3.length
+ > comparands[k].omega )
+ {
+ // This can't be a match, because the rightmost
+ // character of the comparand falls to the right
+ // of the comparand's omega
+ continue;
+ }
+ // A match is theoretically possible, because all
+ // the characters of the comparand fall between
+ // alpha and omega:
+ bool possible_match = true;
+ if( comparands[k].operation != bound_characters_e)
+ {
+ for(size_t m=0; m<comparands[k].identifier_3.length; m++)
+ {
+ if( comparands[k].identifier_3.the_characters[m]
+ != leftmost[m] )
+ {
+ possible_match = false;
+ break;
+ }
+ }
+ }
+ if( possible_match )
+ {
+ // The characters of the comparand match the
+ // characters at leftmost. See if further processing is
+ // indicated:
+
+ bool match = false;
+ switch( comparands[k].operation )
+ {
+ case bound_characters_e:
+ match = true;
+ break;
+
+ case bound_first_e:
+ if( comparands[k].first )
+ {
+ match = true;
+ comparands[k].first = false;
+ }
+ break;
+
+ case bound_all_e:
+ {
+ // We have a match.
+ match = true;
+ break;
+ }
+
+ case bound_leading_e:
+ {
+ if( comparands[k].leading )
+ {
+ match = true;
+ }
+ break;
+ }
+ }
+ if( match )
+ {
+ // We have a match at leftmost. We need to
+ // to replace the characters in normalized_id_1
+ // with the characters from normalized_id_5
+
+ size_t index = leftmost
+ - normalized_id_1.the_characters.c_str();
+ for( size_t l = 0;
+ l < comparands[k].identifier_5.length;
+ l++ )
+ {
+ char ch = comparands[k].identifier_5.
+ the_characters[l];
+ normalized_id_1.the_characters[index++]
+ = ch;
+ }
+ // Adjust the leftmost pointer to point to
+ // the rightmost character of the matched
+ // string, keeping in mind that it will be
+ // bumped again after we break out of the
+ // k<pair_count loop:
+ leftmost
+ += comparands[k].identifier_3.length - 1;
+ break;
+ }
+ }
+ else
+ {
+ comparands[k].leading = false;
+ }
+ }
+ leftmost += 1;
+ }
+
+ // Here is where we take the characters from normalized_id_1 and put them
+ // back into identifier_1. There is some special processing to make sure
+ // an embedded sign in a NumericDisplay survives the processing.
+
+ int index_dest = normalized_id_1.offset;
+ if( identifier_1.field->type == FldNumericDisplay )
+ {
+ for(size_t i=0; i<normalized_id_1.length; i++)
+ {
+ identifier_1.location[index_dest] = normalized_id_1.the_characters[i];
+ if( is_sign_bit_on (normalized_id_1.the_characters[i]) )
+ {
+ turn_sign_bit_on(&identifier_1.location[index_dest]);
+ }
+ else
+ {
+ turn_sign_bit_off(&identifier_1.location[index_dest]);
+ }
+ index_dest += 1;
+ }
+ }
+ else
+ {
+ for(size_t i=0; i<normalized_id_1.length; i++)
+ {
+ identifier_1.location[index_dest++]
+ = normalized_id_1.the_characters[i];
+ }
+ }
+ }
+
+extern "C"
+void
+__gg__inspect_format_4( cblc_refer_t *refer_input_ ,
+ cblc_refer_t *refer_original_ ,
+ cblc_refer_t *refer_replacement_ ,
+ cblc_refer_t *refer_after_ ,
+ cblc_refer_t *refer_before_ )
+ {
+ cblc_resolved_t refer_input ;
+ cblc_resolved_t refer_original ;
+ cblc_resolved_t refer_replacement;
+ cblc_resolved_t refer_after ;
+ cblc_resolved_t refer_before ;
+
+ __gg__refer_resolve(refer_input_ , &refer_input );
+ __gg__refer_resolve(refer_original_ , &refer_original );
+ __gg__refer_resolve(refer_replacement_ , &refer_replacement);
+ __gg__refer_resolve(refer_after_ , &refer_after );
+ __gg__refer_resolve(refer_before_ , &refer_before );
+
+ char *psz_input = format_for_display_local(refer_input );
+ char *psz_original = format_for_display_local(refer_original );
+ char *psz_replacement = format_for_display_local(refer_replacement);
+ char *psz_after = format_for_display_local(refer_after );
+ char *psz_before = format_for_display_local(refer_before );
+
+ // Use a simple map to make this O(N), rather than an O(N-squared),
+ // computational complexity
+ static const unsigned char map_init[256] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f,
+ 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f,
+ 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f,
+ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,
+ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,
+ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,
+ 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,
+ 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf,
+ 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf,
+ 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf,
+ 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
+ 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff
+ };
+ unsigned char map[256];
+ memcpy(map, map_init, 256);
+
+ for(size_t i=0; i<strlen(psz_replacement); i++)
+ {
+ map[ (unsigned char )psz_original[i] ] = (unsigned char )psz_replacement[i];
+ }
+
+ char *pstart = psz_input;
+ char *pend = psz_input + strlen(psz_input);
+ if( strlen(psz_after) )
+ {
+ pstart = strstr(psz_input, psz_after);
+ }
+ if( strlen(psz_before) )
+ {
+ pend = strstr(psz_input, psz_before);
+ }
+ while(pstart && pstart < pend)
+ {
+ *pstart = map[(unsigned char)*pstart];
+ pstart += 1;
+ }
+
+ memcpy(refer_input.location, psz_input, refer_input.length_untrimmed);
+
+ free(psz_input );
+ free(psz_original );
+ free(psz_replacement);
+ free(psz_after );
+ free(psz_before );
+ }
+
+static void
+move_string( cblc_resolved_t &dest,
+ const char *from,
+ size_t strlen_from = (size_t)(-1) )
+ {
+ bool moved = true;
+
+ if( strlen_from == (size_t)(-1) )
+ {
+ strlen_from = strlen(from);
+ }
+
+ switch(dest.field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ {
+ char *to = (char *)dest.location;
+ size_t dest_length = dest.length_untrimmed;
+ size_t source_length = strlen_from;
+ size_t count = std::min(dest_length, source_length);
+
+ if( source_length >= dest_length )
+ {
+ // We have more source characters than places to put them
+ if( dest.field->attr & rjust_e )
+ {
+ // Destination is right-justified, so we
+ // discard the leading source characters:
+ memmove(to,
+ from + (source_length - count),
+ count);
+ }
+ else
+ {
+ // Destination is right-justified, so we
+ // discard the trailing source characters:
+ memmove(to,
+ from,
+ count);
+ }
+ }
+ else
+ {
+ // We have too few source characters to fill the destination.
+ if( dest.field->attr & rjust_e )
+ {
+ // The destination is right-justified, and the source is an
+ // ordinary string too short to fill it. So, we space-fill
+ // the leading characters.
+ memmove(to + (dest_length-count),
+ from,
+ count);
+ memset(to, internal_space, dest_length-count);
+ }
+ else
+ {
+ // The destination is left-justified
+ // We do the move first, in case this is an overlapping move
+ // involving characters that will be space-filled
+ memmove(to,
+ from,
+ count);
+ memset( to + count,
+ internal_space,
+ dest_length-count);
+ }
+ }
+ break;
+ }
+
+ case FldNumericBinary:
+ case FldNumericBin4:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBin5:
+ case FldIndex:
+ {
+ // We are starting with a string, and setting it to a numerical
+ // target.
+ int hyphen;
+ int rdigits;
+ __int128 value = __gg__dirty_to_binary_internal( from,
+ strlen_from,
+ &hyphen,
+ &rdigits);
+ scale_and_assign_internal(dest.field,
+ dest.location,
+ dest.length_untrimmed,
+ value,
+ rdigits,
+ unrounded_e,
+ NULL);
+ break;
+ }
+
+ default:
+ moved = false;
+ break;
+ }
+ if( !moved )
+ {
+ fprintf(stderr, "%s() %s:%d -- We were unable move a string to "
+ "field type %d\n",
+ __func__, __FILE__, __LINE__,
+ dest.field->type);
+ exit(1);
+ }
+ }
+
+static char *
+brute_force_trim(char *str)
+ {
+ char *retval = str;
+ while( *retval == internal_space )
+ {
+ retval += 1;
+ }
+ char *p = retval + strlen(retval)-1;
+ while( p > retval && *p == internal_space )
+ {
+ *p-- = NULLCH;
+ }
+ return retval;
+ }
+
+extern "C"
+int
+__gg__unstring( cblc_refer_t *src_ref,
+ size_t ndelimiteds,
+ cblc_refer_t *delimiteds_ref,
+ char *all_flags,
+ size_t nreceivers,
+ cblc_refer_t *receivers_ref,
+ cblc_refer_t *delimiters_ref,
+ cblc_refer_t *counts_ref,
+ cblc_refer_t *pointer_ref,
+ cblc_refer_t *tally_ref)
+ {
+ // As per the specification, we need to resolve all qualifications upon
+ // launching the UNSTRING:
+
+ // resolve the sending identifier-1:
+ cblc_resolved_t src_res;
+ __gg__refer_resolve(src_ref, &src_res);
+
+ // Resolve all of the DELIMITED BY identifier-2 values
+ std::vector<std::string> delimited_by(ndelimiteds);
+ for(size_t i=0; i<ndelimiteds; i++)
+ {
+ cblc_resolved_t res;
+ __gg__refer_resolve(&delimiteds_ref[i], &res);
+ char *delim = format_for_display_local(res);
+ delimited_by[i] = delim;
+ }
+
+ // For each delimiter, there is an identifier-4 receiver that must be
+ // resolved. Each might have an identifier-5 delimiter, and each might have
+ // an identifier-6 count:
+
+ cblc_resolved_t *receivers = (cblc_resolved_t *)malloc(nreceivers * sizeof(cblc_resolved_t));
+ cblc_resolved_t *delimiters = (cblc_resolved_t *)malloc(nreceivers * sizeof(cblc_resolved_t));
+ cblc_resolved_t *counts = (cblc_resolved_t *)malloc(nreceivers * sizeof(cblc_resolved_t));
+ for(size_t i=0; i<nreceivers; i++)
+ {
+ __gg__refer_resolve(&receivers_ref[i], &receivers[i]);
+ __gg__refer_resolve(&delimiters_ref[i], &delimiters[i]);
+ __gg__refer_resolve(&counts_ref[i], &counts[i]);
+ }
+ cblc_resolved_t pointer_var;
+ __gg__refer_resolve(pointer_ref, &pointer_var);
+ cblc_resolved_t tally_var;
+ __gg__refer_resolve(tally_ref, &tally_var);
+
+ // All of the variables have had their subscripts and refmods resolved. We
+ // can now proceed according to the specification.
+
+ // Initialize the state variables
+ int overflow = 0;
+ int tally = 0;
+ int pointer = 1;
+
+ // Extract the source string.
+ char *src = format_for_display_local(src_res);
+
+ // Trim it, if need be
+ src[src_res.length_trimmed] = NULLCH;
+
+ size_t nreceiver;
+ char *left = NULL;
+ char *right = NULL;
+ std::string previous_delimiter;
+
+ // As per the spec, if the string is zero-length; we are done.
+ if( strlen(src) == 0 )
+ {
+ goto done;
+ }
+
+ // Update pointer with explicit value, if one is provided.
+ if( pointer_ref && pointer_ref->field )
+ {
+ int hyphen;
+ int rdigits;
+ pointer = (int)__gg__binary_value_from_resolved(&hyphen, &rdigits, &pointer_var);
+ }
+
+ // Update tally with explicit value, if one is provided.
+ if( tally_ref && tally_ref->field )
+ {
+ int hyphen;
+ int rdigits;
+ tally = (int)__gg__binary_value_from_resolved(&hyphen, &rdigits, &tally_var);
+ }
+
+ // As per the spec, we have an overflow condition if pointer is out of
+ // range:
+ if( pointer < 1 || pointer > (int)strlen(src) )
+ {
+ overflow = 1;
+ goto done;
+ }
+
+ left = src + pointer-1;
+ right = src + strlen(src);
+
+ if( ndelimiteds == 0 )
+ {
+ // There are no DELIMITED BY identifier-2 values, so we just peel off
+ // characters from identifier-1 and put them into identifier-4:
+ for( size_t i=0; i<nreceivers; i++ )
+ {
+ if( left >= right )
+ {
+ break;
+ }
+ size_t examined;
+ if( (receivers[i].field->attr & refmod_e)
+ || !(receivers[i].field->attr & separate_e) )
+ {
+ // It's a refmod, or it's not separate
+ examined = receivers[i].length_untrimmed;
+ }
+ else
+ {
+ // The receiver is NumericDisplay with a separate signe
+ examined = receivers[i].length_untrimmed - 1;
+ }
+
+ // Make sure examined doesn't move past the end of the universe
+ if( left + examined > right )
+ {
+ examined = right - left;
+ }
+ // Move the data into place:
+ move_string(receivers[i], left, examined);
+
+ // Update the state variables:
+ left += examined;
+ pointer += examined;
+ tally += 1;
+ }
+ goto done;
+ }
+
+ // Arriving here means there is some number of ndelimiteds
+
+ nreceiver = 0;
+ previous_delimiter.clear();
+ while( left < right )
+ {
+ // Starting at 'left', see if we can find any of the delimiters
+ char *leftmost_delimiter = NULL;
+ int ifound = -1;
+ for( size_t i=0; i<ndelimiteds; i++ )
+ {
+ char *pfound = strstr(left, delimited_by[i].c_str());
+ if( pfound )
+ {
+ // We found a delimiter
+ if( !leftmost_delimiter || pfound < leftmost_delimiter )
+ {
+ ifound = i;
+ leftmost_delimiter = pfound;
+ }
+ }
+ }
+
+ if( ifound >= 0
+ && leftmost_delimiter == left
+ && delimited_by[ifound] == previous_delimiter
+ )
+ {
+ // We found another instance of an ALL delimiter.
+ // So, we just skip it.
+ left += previous_delimiter.length();
+ pointer += previous_delimiter.length();
+ continue;
+ }
+ // We did not re-find an ALL DELIMITER
+ previous_delimiter.clear();
+
+ if( nreceiver >= nreceivers )
+ {
+ break;
+ }
+
+ // Arriving here means we found a new delimiter.
+ if( ifound >= 0 && all_flags[ifound] == ascii_1 )
+ {
+ previous_delimiter = delimited_by[ifound];
+ }
+
+ if( !leftmost_delimiter )
+ {
+ // We were unable to find a delimiter, so we eat up the remainder
+ // of the sender:
+ leftmost_delimiter = right;
+ }
+
+ // Apply what we have learned to the next receiver:
+
+ size_t examined = leftmost_delimiter - left;
+
+ // Move the data into place:
+ move_string(receivers[nreceiver], left, examined);
+
+ // Update the left pointer
+ left = leftmost_delimiter;
+ if( ifound >= 0 )
+ {
+ // And skip over the delimiter
+ left += delimited_by[ifound].length();
+ }
+
+ if( delimiters[nreceiver].field )
+ {
+ if( ifound >= 0 )
+ {
+ move_string(delimiters[nreceiver],
+ delimited_by[ifound].c_str());
+ }
+ else
+ {
+ move_string(delimiters[nreceiver], "");
+ }
+ }
+
+ if( counts[nreceiver].field )
+ {
+ char ach[32] = "";
+ sprintf(ach, "%ld", examined);
+ move_string(counts[nreceiver], ach);
+ }
+
+ // Update the state variables:
+ pointer += examined + delimited_by[ifound].length();
+ tally += 1;
+ nreceiver += 1;
+ }
+
+ done:
+
+ if( tally_var.field )
+ {
+ __gg__scale_to_resolved(&tally_var,
+ (__int128)tally,
+ 0,
+ unrounded_e,
+ NULL );
+ }
+
+ if( pointer_var.field )
+ {
+ __gg__scale_to_resolved(&pointer_var,
+ (__int128)pointer,
+ 0,
+ unrounded_e,
+ NULL );
+ }
+
+ if( left < right )
+ {
+ overflow = 1;
+ }
+
+ free(counts);
+ free(delimiters);
+ free(receivers);
+ free(src);
+ return overflow;
+ }
+
+extern "C"
+int
+__gg__string( size_t integers[],
+ cblc_refer_t refers[])
+ {
+ // The first integer is the count of identifier-2 values. Call it N
+ // The following N integers are the counts of each of the identifier-1 values,
+ // one for each identifier-1. Call them M.
+
+ // The first refer is the target
+ // The second refer is the pointer
+ // The third refer is identifier-2 for N1
+ // That's followed by M1 identifier-1 values
+ // That's followed by identifier2 for N2
+ // And so on
+ static const int INDEX_OF_POINTER = 1;
+
+ size_t index_int = 0;
+ size_t index_cblc = 0 ;
+
+ // Pick up the number of identifier-2 values
+ size_t N = integers[index_int++];
+
+ // Pick up the target
+ cblc_resolved_t tgt;
+ __gg__refer_resolve(&refers[index_cblc++], &tgt);
+ char *dest = (char *)tgt.location;
+ ssize_t dest_length = tgt.length_untrimmed;
+
+ // Skip over the index of POINTER:
+ index_cblc += 1;
+
+ // Pick up the pointer, if any
+ ssize_t pointer = 0;
+ if( refers[INDEX_OF_POINTER].field )
+ {
+ int hyphen;
+ int rdigits;
+ pointer = (size_t)__gg__binary_value_from_refer(&hyphen, &rdigits, &refers[INDEX_OF_POINTER]);
+ pointer -= 1;
+ }
+
+ int overflow = 0;
+
+ // Make sure that the destination pointer is within the destination
+ if( pointer >= 0 || pointer < dest_length )
+ {
+ // We are go for looping through identifier-2 values:
+
+ for( size_t i=0; i<N; i++ )
+ {
+ size_t M = integers[index_int++];
+
+ // Pick up the identifier_2 DELIMITED BY value
+ cblc_resolved_t identifier_2;
+ __gg__refer_resolve(&refers[index_cblc++], &identifier_2);
+
+ char *piece = (char *)identifier_2.location;
+ char *piece_end = piece + identifier_2.length_untrimmed;
+
+ for(size_t i=0; i<M; i++)
+ {
+ // Pick up the next identifier-1 source string:
+ cblc_resolved_t identifier_1;
+ __gg__refer_resolve(&refers[index_cblc++], &identifier_1);
+
+ const char *whole = (const char *)identifier_1.location;
+ const char *whole_end = whole + identifier_1.length_trimmed;
+
+ // As usual, we need to cope with figurative constants:
+ cbl_figconst_t figconst = (cbl_figconst_t)(identifier_1.field->attr & FIGCONST_MASK);
+ char figlow[2] = {ascii_to_internal(low_value_character), 0x00};
+ char fighigh[2] = "";
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ fighigh[0] = high_value_character;
+ }
+ else
+ {
+ fighigh[0] = ascii_to_internal(high_value_character);
+ }
+ char figzero[2] = {internal_zero, 0x00};
+ char figquote[2] = {ascii_to_internal(quote_character), 0x00};
+ char figspace[2] = {internal_space, 0x00};
+ switch( figconst )
+ {
+ case low_value_e:
+ whole = figlow;
+ whole_end = whole + 1;
+ break;
+ case zero_value_e:
+ whole = figzero;
+ whole_end = whole + 1;
+ break;
+ case space_value_e:
+ whole = figspace;
+ whole_end = whole + 1;
+ break;
+ case quote_value_e:
+ whole = figquote;
+ whole_end = whole + 1;
+ break;
+ case high_value_e:
+ whole = fighigh;
+ whole_end = whole + 1;
+ break;
+ default:
+ break;
+ }
+
+ if(piece)
+ {
+ const char *found = funky_find( piece, piece_end,
+ whole, whole_end);
+ if(found)
+ {
+ #pragma GCC diagnostic push
+ #pragma GCC diagnostic ignored "-Wcast-qual"
+ char *wfound = (char *)found;
+ #pragma GCC diagnostic pop
+ whole_end = wfound;
+ }
+ }
+ while(whole < whole_end)
+ {
+ if(pointer >= dest_length)
+ {
+ overflow = 1;
+ break;
+ }
+ dest[pointer++] = *whole++;
+ }
+ if( overflow )
+ {
+ break;
+ }
+ }
+ }
+
+ // Update the pointer, if there is one
+ if( refers[1].field )
+ {
+ __gg__scale_to_refer( &refers[INDEX_OF_POINTER], (__int128)(pointer+1), 0, unrounded_e, NULL );
+ }
+ }
+ else
+ {
+ // The initial pointer is not inside the destination
+ overflow = 1;
+ }
+
+ return overflow;
+ }
+
+extern "C"
+void
+__gg__refer_resolve(
+ cblc_refer_t *refer,
+ cblc_resolved_t *resolved)
+ {
+ if( refer->field )
+ {
+ // Initialize the field to the no-subscript, no-refmod state:
+ resolved->field = refer->field;
+ resolved->location = refer->field->data;
+ resolved->length_untrimmed = refer->field->capacity;
+ resolved->length_trimmed = refer->field->capacity;
+ resolved->move_all = ((refer->flags & MOVE_ALL_FLAG) != 0);
+ resolved->addr_of = ((refer->flags & ADDR_OF_FLAG) != 0);
+ refer->field->attr &= ~(refmod_e | oob_read_e | oob_write_e);
+
+ int hyphen;
+ int rdigits;
+
+ // This is where we apply table subscripts. We will look at the table
+ // subscripts from right to left. That will match the behavior of the
+ // chain of tables, which we walk from the youngest grandchild up to the
+ // oldest ancestor:
+
+ resolved->all_flags = 0;
+ size_t all_flag_bit = 1;
+
+ cblc_field_t *current_sizer = refer->field;
+
+ for(size_t i=refer->nsubscripts-1; i<refer->nsubscripts; i--)
+ {
+ // Note the oddball termination; size_t is unsigned, so it wraps from
+ // zero to huge
+
+ // Scan upwards through the heirarchy, looking for a table:
+ while( current_sizer && !current_sizer->occurs_upper )
+ {
+ // current_sizer isn't a table, which isn't unusual.
+ current_sizer = current_sizer->parent;
+ }
+
+ if( !current_sizer )
+ {
+ fprintf(stderr, "%s(): The number of nested tables in"
+ " the heirarchy is incorrect\n", __func__);
+ exit(1);
+ }
+
+ // We pick up the subscript.
+ size_t subscript;
+ subscript = (size_t)__gg__binary_value_from_field( &hyphen,
+ &rdigits,
+ refer->subscripts[i] );
+
+ // COBOL allows for the word ALL instead of a subscript. Our logic
+ // uses a subscript value of ZERO to flag all; we pick that up here.
+ if( subscript == 0 )
+ {
+ // Replace it with one, as per the specification:
+ subscript = 1;
+
+ // Flag this position as ALL
+ resolved->all_flags |= all_flag_bit;
+ }
+ all_flag_bit <<= 1;
+
+ if( subscript < 1
+ || subscript > (size_t)current_sizer->occurs_upper )
+ {
+ // The subscript has to be between 1 and occurs_upper.
+ // It's not, so we are totally out of bounds for both reads and
+ // writes:
+ refer->field->attr |= (oob_read_e | oob_write_e);
+ }
+
+ // As per the language specification, writes are bounded only by
+ // occurs_upper. Reads, however, are subject to DEPENDING ON. As of
+ // this writing, I am establishing the oob_read_e and oob_write_e
+ // bits, but we are not looking at them consistently.
+
+ // The specification is not forthcoming about what to do. Accessing
+ // oob data is covered by this comment in the IBM Language
+ // Reference: "The behavior is undefined if the value of the object
+ // is outside of the range integer-1 through integer-2."
+
+ // So, as of this writing, I am going to simply allow reads and
+ // between 1 and occurs_upper to take place, since that strikes me
+ // as being covered by "undefined behavior". If a subscript is less
+ // than 1, or greater than occurs_upper, I am going to set location
+ // to zero and length to zero, which will result in a SEGFAULT,
+ // which strikes me, at this point in development to be perfectly
+ // legitimate.
+
+ size_t depending_on = current_sizer->occurs_upper;
+ if( current_sizer->depending_on )
+ {
+ depending_on = (size_t)__gg__binary_value_from_field(&hyphen, &rdigits, current_sizer->depending_on);
+ }
+
+ if( subscript > depending_on )
+ {
+ refer->field->attr |= oob_read_e;
+ }
+
+ // We are going to do these calculations without regard to the oob
+ // signals. Recall that the cobol subscript is one-based, not zero-based
+
+ resolved->location += (subscript-1) * current_sizer->capacity;
+
+ current_sizer = current_sizer->parent;
+ }
+
+ // We have some special processing here. In the case of a quoted field
+ // literal, we want to point to the original initial information:
+
+ if( refer->field->type == FldLiteral && (refer->field->attr & quoted_e) )
+ {
+ resolved->location = (unsigned char *)refer->field->initial;
+ resolved->length_untrimmed = strlen(refer->field->initial);
+ resolved->length_trimmed = strlen(refer->field->initial);
+ }
+
+ // We check to see if we, or anybody subordinate to us, has a DEPENDING
+ // ON clause.
+
+ cblc_field_t *depends_on = refer->field->depends_on;
+ if( depends_on )
+ {
+ size_t occurs = refer->field->depends_on->occurs_upper;
+ size_t depending_on = (size_t)__gg__binary_value_from_field(&hyphen, &rdigits, refer->field->depends_on->depending_on);
+ //fprintf(stderr, "We depend on %s\n", refer->field->depends_on->name);
+ //fprintf(stderr, "OCCURS is %ld\n", occurs);
+ //fprintf(stderr, "DEPENDING ON is %s (%ld)\n", refer->field->depends_on->depending_on->name, depending_on);
+ resolved->length_trimmed -= (occurs-depending_on) * refer->field->depends_on->capacity;
+ }
+
+ // With tables out of the way, take a look at refmods:
+
+ if( refer->refmod_from || refer->refmod_len)
+ {
+ size_t r_from ;
+ size_t r_len ;
+
+ if( refer->refmod_from )
+ {
+ r_from = (size_t)__gg__binary_value_from_field(&hyphen,
+ &rdigits,
+ refer->refmod_from );
+ }
+ else
+ {
+ // This is the default if the FROM value is missing
+ r_from = 1;
+ }
+
+ if( refer->refmod_len )
+ {
+ r_len = (size_t)__gg__binary_value_from_field( &hyphen,
+ &rdigits,
+ refer->refmod_len );
+ }
+ else
+ {
+ // If the LENGTH value is missing, we run out to the end of the
+ // data
+ r_len = resolved->length_trimmed - (r_from-1);
+ }
+
+ if( r_from > resolved->length_trimmed )
+ {
+ fprintf(stderr, "%s(): Reference modification start value"
+ " exceeds object capacity\n", __func__);
+ exit(1);
+ }
+ if( r_len < 1 )
+ {
+ fprintf(stderr, "%s(): Reference modification length value"
+ " is less than 1\n", __func__);
+ exit(1);
+ }
+
+ if( r_from-1 + r_len > resolved->length_untrimmed )
+ {
+ fprintf(stderr, "%s(): Reference modification start+length"
+ " exceeds object capacity\n", __func__);
+ exit(1);
+ }
+
+ if( r_from != 1 || r_len != resolved->length_untrimmed )
+ {
+ // We have a valid refmod
+ refer->field->attr |= refmod_e;
+ resolved->location += r_from-1;
+ resolved->length_untrimmed = r_len;
+ resolved->length_trimmed = r_len;
+ }
+ }
+ if( refer->field->attr & oob_write_e )
+ {
+ // oob_write_e means that a subscript was less than 1 or greater
+ // than occurs_upper. Let's set our user up for a fall:
+ fprintf(stderr,
+ "%s has an out-of_bounds subscript\n",
+ refer->field->name );
+ resolved->location = NULL;
+ resolved->length_untrimmed = 0;
+ resolved->length_trimmed = 0;
+ }
+ }
+ else
+ {
+ memset(resolved, 0, sizeof(cblc_resolved_t));
+ }
+ }
+
+extern "C"
+void
+__gg__get_location_and_length( unsigned char **location,
+ size_t *length,
+ cblc_refer_t *var_ref
+ )
+ {
+ cblc_resolved_t var;
+ __gg__refer_resolve(var_ref, &var);
+ *location = var.location;
+ *length = var.length_untrimmed;
+ }
+
+extern "C"
+void
+__gg__get_location_and_length_trimmed( unsigned char **location,
+ size_t *length,
+ cblc_refer_t *var_ref
+ )
+ {
+ cblc_resolved_t var;
+ __gg__refer_resolve(var_ref, &var);
+ *location = var.location;
+ *length = var.length_trimmed;
+ }
+
+extern "C"
+void
+__gg__display( cblc_refer_t *var_ref,
+ int file_descriptor,
+ int advance )
+ {
+ cblc_resolved_t var;
+
+ __gg__refer_resolve(var_ref, &var);
+
+ char *display_string = format_for_display_internal( var.field,
+ var.location,
+ var.length_trimmed );
+
+ // Let's honor the locale of the system, as best we can:
+
+ char *converted =
+ internal_to_console(display_string, strlen(display_string));
+
+ ssize_t ss = write( file_descriptor,
+ converted,
+ strlen(converted));
+ assert(ss != -1);
+
+ free(converted);
+ free(display_string);
+
+ if( advance )
+ {
+ ss = write( file_descriptor,
+ "\n",
+ 1);
+ }
+ }
+
+static int
+TOLOWER(int ch)
+ {
+ // This operates in the ASCII source codeset
+ if( ch >= ascii_A && ch <= ascii_Z )
+ {
+ ch |= 0x20;
+ }
+ return ch;
+ }
+
+extern "C"
+char *
+__gg__name_mangler( cblc_refer_t *var_ref )
+ {
+ // This routine is used when the COBOL instruction CALL data-identifier-1
+ // is invoked. The contents of data-identifier-1 is the name of the
+ // function being called, so it has to be mangled to get rid of hyphens.
+
+ // This code needs to match the compile-time cobol_name_mangler() routine
+ // found in cobol1.c
+
+ // This is a definitive solution to the problem of hyphens. COBOL
+ // names can't start with underscore; GNU assembler names can.
+ // Thus, the 12-char name RE-TURN-CODE gets converted to
+ // _12RE_TURN_CODE2_7 The 2 and 7 are the offsets to the underscore
+ // characters that get turned back into hyphens to reconstruct the original
+
+ // Names without hyphens just get converted to lowercase; no prefix or postfix.
+
+ // We need to build that string. I don't know how long cobol_name
+ // can be. If it is nothing but N hyphens, then I need room for N * (_123)
+ // characters at the end, and four characters at the beginning. This is
+ // excessive (the counts and indexes will basically never be greater
+ // than 100), but, well, talk to the hand.
+
+ cblc_resolved_t var;
+ __gg__refer_resolve(var_ref, &var);
+
+ // var contains the name in the internal codeset; from here on out we want
+ // to be working in the ascii domain:
+
+ char *unmangled = internal_to_console((char *)var.location, var.length_untrimmed);
+
+ // Convert the cobol_name_ to lowercase
+ const char *s = (char *)unmangled;
+ const char *eos = s + var.length_untrimmed;
+ bool has_dash = false;
+
+ size_t N = var.length_untrimmed;
+ size_t NLENGTH = 5 + N + (N-1)*4;
+
+ char * const cobol_name = (char *)malloc(N+1);
+ char *d = cobol_name;
+
+ if( s[0] >= ascii_0 && s[0] <= ascii_9 )
+ {
+ has_dash = true;
+ }
+
+ while(s < eos)
+ {
+ int ch = *s++;
+ if( ch == ascii_hyphen )
+ {
+ has_dash = true;
+ }
+ *d++ = TOLOWER(ch);
+ }
+ *d++ = NULLCH;
+
+ free(unmangled);
+ unmangled = NULL;
+
+ int nlength = strlen(cobol_name);
+ char *psz = (char *)malloc(NLENGTH);
+ char achsuffix[12];
+ int offset;
+ if( has_dash )
+ {
+ // There is at least one hyphen:
+ // Put the length of cobol_string at the front:
+ offset = sprintf(psz,"_%zd_",strlen(cobol_name));
+
+ // tack on the actual cobol_name
+ strcat(psz,cobol_name);
+
+ // walk the name, looking for hyphens:
+ int more_than_one = 0;
+ for(int i=0; i<nlength; i++)
+ {
+ if( psz[offset + i] == ascii_hyphen )
+ {
+ // Convert the hyphen to an underscore
+ psz[offset + i] = ascii_underscore;
+
+ // Append the index to the underscore:
+ static char underscore[2] = {ascii_underscore, NULLCH};
+ sprintf(achsuffix,
+ "%s%d",
+ (more_than_one++ ? underscore : ""),
+ i);
+ strcat(psz,achsuffix);
+ }
+ }
+ }
+ else
+ {
+ strcpy(psz,cobol_name);
+ }
+ free(cobol_name);
+ return psz;
+ }
+
+extern "C"
+void
+__gg__accept( enum special_name_t special_e,
+ cblc_refer_t *var_)
+ {
+ int file_descriptor = 0; // We are always working from stdin
+
+
+ cblc_resolved_t var;
+ __gg__refer_resolve(var_, &var);
+
+ if( var.field->attr & oob_write_e )
+ {
+ // Do nothing instead of an out-of-bounds write:
+ return;
+ }
+
+ size_t max_chars = var.length_untrimmed;
+
+ if( special_e == CONSOLE_e )
+ {
+ // Welcome to the land of possibly screwball assumptions. If reading
+ // from CONSOLE/stdin it's possible that the target variable is
+ // a NumericBinary of length 4, which can hold a 10-digit number. So,
+ // we need room to accept the characters, which will later on be converted
+ // to a binary value.
+
+ // But SYSIN and SYSIPT seem to require that characters be read until the
+ // size of the target variable is satisfied, which implies further that
+ // the target must be alphanumeric.
+
+ // What reality will ultimately offer is unknown to me. But I'm doing
+ // the best I can with what I've got, and, right now, this is what
+ // I've got.
+ if( var.length_untrimmed < 64 )
+ {
+ // Set a floor for the length of the buffer. This will let us cope
+ // with, say, a four-byte binary value that can hold ten digits
+ max_chars = 64;
+ }
+ }
+
+ char *buffer = (char *)malloc(max_chars+1);
+ memset(buffer, ascii_space, max_chars);
+ buffer[max_chars] = NULLCH;
+ size_t i = 0;
+
+ for(;;)
+ {
+ char ch;
+ ssize_t bytes_read = read(file_descriptor, &ch, 1);
+ if( bytes_read <= 0 )
+ {
+ // Error or end-of-file, so give up
+ break;
+ }
+
+ if( ch == '\n' )
+ {
+ // End-of-line
+ if( special_e == CONSOLE_e )
+ {
+ // When reading from the console, a newline means that the
+ // typist pressed ENTER/RETURN, and the input is done. This is
+ // also the case even when stdin was redirected from a file or
+ // another process
+ break;
+ }
+ else
+ {
+ // But if SYSIN_e or SYSIPT_e was specified, we are emulating
+ // the universe of punched cards, so we just keep reading in
+ // characters until we have read in max_chars. We found it
+ // necessary to implement ACCEPT in this fashion to get the
+ // NIST test suite to work.
+
+ // Note that in both cases, we keep reading until we hit
+ // an actual newline or end-of-file
+
+ if( i >= max_chars )
+ {
+ break;
+ }
+ continue;
+ }
+ }
+ if(i < max_chars)
+ {
+ buffer[i++] = ch;
+ }
+ }
+
+ switch(var.field->type)
+ {
+ case FldGroup :
+ case FldAlphanumeric :
+ case FldAlphaEdited :
+ console_to_internal(buffer, i);
+ move_string(var, buffer, strlen(buffer));
+ break;
+
+ case FldNumericDisplay:
+ {
+ // In the NIST tests, feeding ten digits 0123456789 into a
+ // PIC 9(9) results in a nine-digit 012345678 rather than our
+ // default 123456789
+
+ int digit_count = 0;
+ char *p = buffer;
+ while(*p && digit_count < var.field->digits)
+ {
+ if( *p == decimal_point )
+ {
+ p += 1;
+ continue;
+ }
+
+ switch(*p)
+ {
+ case ascii_0:
+ case ascii_1:
+ case ascii_2:
+ case ascii_3:
+ case ascii_4:
+ case ascii_5:
+ case ascii_6:
+ case ascii_7:
+ case ascii_8:
+ case ascii_9:
+ p += 1;
+ digit_count += 1;
+ continue;
+ break;
+ case ascii_minus:
+ case ascii_plus:
+ p += 1;
+ continue;
+ break;
+ default:
+ goto we_are_done;
+ break;
+ }
+ }
+ we_are_done:
+ *p = NULLCH;
+
+ int hyphen;
+ int rdigits;
+ __int128 value = __gg__dirty_to_binary_source( buffer,
+ (int)i,
+ &hyphen,
+ &rdigits);
+
+ __gg__scale_to_refer( var_,
+ value,
+ rdigits,
+ rounded_e,
+ NULL);
+ break;
+ }
+
+ default:
+ {
+ int hyphen;
+ int rdigits;
+
+ __int128 value = __gg__dirty_to_binary_source( buffer,
+ (int)i,
+ &hyphen,
+ &rdigits);
+
+ __gg__scale_to_refer( var_,
+ value,
+ rdigits,
+ rounded_e,
+ NULL);
+ break;
+ }
+ }
+ free(buffer);
+ }
+
+extern "C"
+__int128
+__gg__binary_value_from_field( int *hyphen,
+ int *rdigits,
+ cblc_field_t *var)
+ {
+ return get_binary_value_local( hyphen,
+ rdigits,
+ var,
+ var->data,
+ var->capacity);
+ }
+
+extern "C"
+__int128
+__gg__binary_value_from_refer( int *hyphen,
+ int *rdigits,
+ cblc_refer_t *var_ref)
+ {
+ cblc_resolved_t var;
+ __gg__refer_resolve(var_ref, &var);
+
+ return get_binary_value_local( hyphen,
+ rdigits,
+ var.field,
+ var.location,
+ var.length_trimmed);
+ }
+
+extern "C"
+__int128
+__gg__binary_value_from_resolved( int *hyphen,
+ int *rdigits,
+ cblc_resolved_t *resolved)
+ {
+ return get_binary_value_local( hyphen,
+ rdigits,
+ resolved->field,
+ resolved->location,
+ resolved->length_trimmed);
+ }
+
+extern "C"
+__int128
+__gg__binary_value_from_resolved_internal( int *hyphen,
+ int *rdigits,
+ cblc_resolved_t *resolved)
+ {
+ return get_binary_value_local( hyphen,
+ rdigits,
+ resolved->field,
+ resolved->location,
+ resolved->length_trimmed);
+ }
+
+extern "C"
+void
+__gg__scale_and_assign_to_field(cblc_field_t *tgt,
+ __int128 value,
+ int source_rdigits,
+ enum rounded_t rounded,
+ bool *perror)
+ {
+ scale_and_assign_internal( tgt,
+ tgt->data,
+ tgt->capacity,
+ value,
+ source_rdigits,
+ rounded,
+ perror);
+ }
+
+extern "C"
+void
+__gg__scale_to_refer( cblc_refer_t *refer,
+ __int128 value,
+ int source_rdigits,
+ enum rounded_t rounded,
+ bool *perror)
+ {
+ cblc_resolved_t resolved;
+ __gg__refer_resolve(refer, &resolved);
+
+ scale_and_assign_internal( resolved.field,
+ resolved.location,
+ resolved.length_untrimmed,
+ value,
+ source_rdigits,
+ rounded,
+ perror);
+ }
+
+extern "C"
+void
+__gg__scale_to_resolved( cblc_resolved_t *resolved,
+ __int128 value,
+ int source_rdigits,
+ enum rounded_t rounded,
+ bool *perror)
+ {
+ scale_and_assign_internal( resolved->field,
+ resolved->location,
+ resolved->length_untrimmed,
+ value,
+ source_rdigits,
+ rounded,
+ perror);
+ }
+
+extern "C"
+bool
+__gg__bitop(cblc_field_t *a,
+ bitop_t op,
+ size_t bitmask)
+ {
+ bool retval = false;
+ int hyphen;
+ int rdigits;
+ __int128 value = __gg__binary_value_from_field(&hyphen, &rdigits, a);
+ switch(op)
+ {
+ case bit_set_op: // set bit on
+ value |= bitmask;
+ __gg__scale_and_assign_to_field(a,
+ value,
+ 0,
+ unrounded_e,
+ NULL);
+ break;
+
+ case bit_clear_op: // set bit off
+ value &= ~bitmask;
+ __gg__scale_and_assign_to_field(a,
+ value,
+ 0,
+ unrounded_e,
+ NULL);
+ break;
+
+ case bit_on_op: // true if bit is on
+ retval = bitmask & value;
+ break;
+
+ case bit_off_op: // true if bit is off
+ retval = bitmask & ~value;
+ break;
+ }
+
+ return retval;
+ }
+
+extern "C"
+void
+__gg__set_initial_switch_value( cblc_field_t *upsi )
+ {
+ // We need to establish the initial value of the UPSI-1 switch register
+ // We are using IBM's conventions:
+ // https://www.ibm.com/docs/en/zvse/6.2?topic=SSB27H_6.2.0/fa2sf_communicate_appl_progs_via_job_control.html
+ // UPSI 10000110 means that bits 0, 5, and 6 are on, which means that SW-0, SW-5, and SW-6 are on.
+
+ __int128 value = 0;
+ __int128 bit = 1;
+ char ach[129];
+ memset(ach, 0, sizeof(ach));
+ char *p = getenv("UPSI");
+ if( p )
+ {
+ strncpy(ach, p, sizeof(ach)-1 );
+ p = ach;
+ while(*p)
+ {
+ if( *p++ == ascii_1 )
+ {
+ value |= bit;
+ }
+ bit <<= 1 ;
+ }
+ }
+ scale_and_assign_internal( upsi,
+ upsi->data,
+ upsi->capacity,
+ value,
+ 0,
+ unrounded_e,
+ NULL);
+ }
+
+extern "C"
+int
+__gg__classify( classify_t type, cblc_refer_t *str_)
+ {
+ // The default answer is TRUE
+ int retval = 1;
+
+ cblc_resolved_t str;
+ __gg__refer_resolve(str_, &str);
+
+ const char *alpha = (char *)str.location;
+
+ size_t str_length = str.length_trimmed;
+
+ const char *omega = alpha + str_length;
+
+ if(alpha >= omega)
+ {
+ // If there is nothing there, then it can't be TRUE. Can it?
+ retval = 0;
+ }
+
+ unsigned char ch;
+ switch(type)
+ {
+ case ClassNumericType:
+ {
+ bool sign_is_okay = str.field->attr & signable_e;
+
+ char *working_string = (char *)malloc(str_length + 1);
+ memcpy(working_string, alpha, str_length);
+ working_string[str_length] = NULLCH;
+
+ // This is more complicated than it ought to be
+ if( sign_is_okay )
+ {
+ if( str.field->type == FldNumericEdited )
+ {
+ if( str_length >= 2)
+ {
+ // If the final two characters are CR or DB, indicating
+ // a negative value, replace them with zeroes, because
+ // they are valid parts of a NumericEdited numeric
+
+ unsigned int ch1 = working_string[str_length-2] & 0xFF ;
+ if( ch1 == internal_c )
+ {
+ ch1 = internal_C;
+ }
+ else if( ch1 == internal_d )
+ {
+ ch1 = internal_D;
+ }
+ unsigned int ch2 = working_string[str_length-1] & 0xFF ;
+ if( ch2 == internal_r )
+ {
+ ch2 = internal_R;
+ }
+ else if( ch2 == internal_b )
+ {
+ ch2 = internal_B;
+ }
+
+ if( (ch1 == internal_C && ch2 == internal_R )
+ || (ch1 == internal_D && ch2 == internal_B ) )
+ {
+ working_string[str_length-2] = internal_0;
+ working_string[str_length-1] = internal_0;
+ }
+ }
+ for(size_t i=0; i<str_length; i++)
+ {
+ // This is a little ham-handed, because we are ignoring
+ // the position of the plus or minus, which is bogus:
+ // 123+456 is *not* numeric. But, frankly, I got bored.
+ if( working_string[i]
+ == internal_plus || working_string[i] == internal_minus)
+ {
+ working_string[i] = internal_0;
+ }
+ }
+ }
+ else if( str.field->type == FldNumericDisplay )
+ {
+ char *p_sign;
+ if( str.field->attr & leading_e )
+ {
+ p_sign = working_string;
+ }
+ else
+ {
+ p_sign = working_string + str_length-1;
+ }
+ if( str.field->attr & separate_e )
+ {
+ if( str.field->attr & leading_e )
+ {
+ p_sign = working_string;
+ }
+ else
+ {
+ p_sign = working_string + str_length-1;
+ }
+ if(*p_sign == internal_plus || *p_sign == internal_minus )
+ {
+ *p_sign = internal_0;
+ }
+ else
+ {
+ // Force a failure
+ *p_sign = internal_X;
+ }
+ }
+ else
+ {
+ // The sign is *not* separate:
+ turn_sign_bit_off((unsigned char *)p_sign);
+ }
+ }
+ }
+ // At this point, working string has had sign indicators turned
+ // to the OFF state, leaving digits 0-9.
+
+ for(size_t i=0; i<str_length; i++)
+ {
+ ch = working_string[i] & 0xFF ;
+ if( ch < internal_0 || ch > internal_9 )
+ {
+ retval = 0;
+ break;
+ }
+ }
+ free(working_string);
+ break;
+ }
+
+ case ClassAlphabeticType:
+ while(alpha < omega)
+ {
+ ch = (*alpha++)&0xFF;
+ if( ch == internal_space )
+ {
+ continue;
+ }
+ // If necessary, this can be sped up with the creation of
+ // appropriate mapping tables.
+ if(!( (ch >= internal_A && ch <= internal_I)
+ || (ch >= internal_J && ch <= internal_R)
+ || (ch >= internal_S && ch <= internal_Z)
+ || (ch >= internal_a && ch <= internal_i)
+ || (ch >= internal_j && ch <= internal_r)
+ || (ch >= internal_s && ch <= internal_z) ) )
+ {
+ // The character is not alphabetic
+ retval = 0;
+ break;
+ }
+ }
+ break;
+
+ case ClassLowerType:
+ while(alpha < omega)
+ {
+ ch = *alpha++;
+ if( ch == internal_space )
+ {
+ continue;
+ }
+ if(!( (ch >= internal_a && ch <= internal_i)
+ || (ch >= internal_j && ch <= internal_r)
+ || (ch >= internal_s && ch <= internal_z) ) )
+ {
+ retval = 0;
+ break;
+ }
+ }
+ break;
+ case ClassUpperType:
+ while(alpha < omega)
+ {
+ ch = *alpha++;
+ if( ch == internal_space )
+ {
+ continue;
+ }
+ if(!( (ch >= internal_A && ch <= internal_I)
+ || (ch >= internal_J && ch <= internal_R)
+ || (ch >= internal_S && ch <= internal_Z) ) )
+ {
+ retval = 0;
+ break;
+ }
+ }
+ break;
+
+ case ClassInvalidType:
+ case ClassDbcsType:
+ case ClassKanjiType:
+ default:
+ warnx("%s(): Don't know how to handle cblc_refer_t %d", __func__, type);
+ abort();
+ break;
+ }
+
+ return retval;
+ }
+
+extern "C"
+bool
+__gg__accept_envar(cblc_refer_t *var_, cblc_refer_t *name_)
+ {
+ cblc_resolved_t var;
+ cblc_resolved_t name;
+
+ __gg__refer_resolve(var_, &var);
+ __gg__refer_resolve(name_, &name);
+
+ bool retval = false; // true means the variable existed:
+ char *env_name = format_for_display_internal( name.field,
+ name.location,
+ name.length_untrimmed);
+ char *trimmed_env_name = brute_force_trim(env_name);
+ const char *p = getenv(trimmed_env_name);
+ if(p)
+ {
+ retval = true;
+ move_string(var, p);
+ }
+ else
+ {
+ // Set the destination to LOW_VALUE
+ memset(var.location, 0, var.length_untrimmed);
+ }
+
+ free(env_name);
+
+ return retval;
+ }
+
+extern "C"
+bool
+__gg__set_envar(cblc_refer_t *name_, cblc_refer_t *var_)
+ {
+ cblc_resolved_t name;
+ cblc_resolved_t var;
+
+ __gg__refer_resolve(name_, &name);
+ __gg__refer_resolve(var_, &var);
+
+ bool retval = false; // true means the variable existed:
+
+ char *env_name = format_for_display_internal( name.field,
+ name.location,
+ name.length_untrimmed);
+ char *trimmed_env_name = brute_force_trim(env_name);
+
+ char *var_str = format_for_display_internal( var.field,
+ var.location,
+ var.length_untrimmed);
+
+ char *trimmed_var_str = brute_force_trim(var_str);
+
+ if( getenv(env_name) )
+ {
+ // It already existed:
+ retval = true;
+ }
+
+ setenv(trimmed_env_name, trimmed_var_str, 1);
+
+ free(var_str);
+ free(env_name);
+ return retval;
+ }
+
+static int stashed_argc;
+static char **stashed_argv;
+
+extern "C"
+void
+__gg__stash_argc_argv(int argc, char **argv)
+ {
+ stashed_argc = argc;
+ stashed_argv = argv;
+ }
+
+extern "C"
+void
+__gg__get_argc(cblc_refer_t *dest_)
+ {
+ cblc_resolved_t dest;
+ __gg__refer_resolve(dest_, &dest);
+
+ char ach[128];
+ sprintf(ach, "%d", stashed_argc);
+ ascii_to_internal_str(ach, strlen(ach));
+ move_string(dest, ach);
+ }
+
+extern "C"
+void
+__gg__get_argv(cblc_refer_t *dest_, cblc_refer_t *index_)
+ {
+ cblc_resolved_t dest;
+ __gg__refer_resolve(dest_, &dest);
+
+ cblc_resolved_t index;
+ __gg__refer_resolve(index_, &index);
+
+ int hyphen;
+ int rdigits;
+
+ __int128 N = get_binary_value_local( &hyphen,
+ &rdigits,
+ index.field,
+ index.location,
+ index.length_untrimmed);
+
+ // If he gives us fractional digits, just truncate
+ N /= __gg__power_of_ten(rdigits);
+
+ if( N >= stashed_argc || N < 0 )
+ {
+ // When N is out of range, set the destination to LOW_VALUE
+ memset(dest.location, 0, dest.length_untrimmed);
+ }
+ else
+ {
+ char *retval = strdup(stashed_argv[N]);
+ console_to_internal(retval, strlen(retval));
+ move_string(dest, retval);
+ free(retval);
+ }
+ }
+
+extern "C"
+void
+__gg__get_command_line(cblc_refer_t *dest_)
+ {
+ cblc_resolved_t dest;
+ __gg__refer_resolve(dest_, &dest);
+
+ size_t length = 1;
+ char *retval = (char *)malloc(length);
+ *retval = NULLCH;
+
+ for( int i=1; i<stashed_argc; i++ )
+ {
+ while( strlen(retval) + strlen(stashed_argv[i]) + 2 > length )
+ {
+ length *= 2;
+ retval = (char *)realloc(retval, length);
+ }
+ if( *retval )
+ {
+ strcat(retval, " ");
+ }
+ strcat(retval, stashed_argv[i]);
+ }
+
+ console_to_internal(retval, strlen(retval));
+ move_string(dest, retval);
+ free(retval);
+ }
+
+extern "C"
+void
+__gg__set_pointer( cblc_refer_t *target_,
+ cblc_refer_t *source_)
+ {
+ cblc_resolved_t target;
+ __gg__refer_resolve(target_, &target);
+ cblc_resolved_t source;
+ __gg__refer_resolve(source_, &source);
+
+ void *source_address;
+ if( source.addr_of )
+ {
+ // This is SET <something> TO ADDRESS OF SOURCE
+ source_address = source.location;
+ }
+ else
+ {
+ // This is SET <something> TO POINTER
+ if( source.field )
+ {
+ source_address = *(void **)source.location;
+ }
+ else
+ {
+ // This is SET xxx TO NULL
+ source_address = NULL;
+ }
+ }
+
+ if( target.addr_of )
+ {
+ // This is SET ADDRESS OF target TO ....
+ // We know it has to be an unqualified LINKAGE level 01 or level 77
+ target_->field->data = (unsigned char *)source_address;
+ // The caller will propogate data + offset to their children.
+ }
+ else
+ {
+ // This is SET <pointer> TO ....
+ *(void **)target.location = source_address;
+ }
+ }
+
+struct alphabet_state
+ {
+ unsigned char collation[256];
+ unsigned char low_char;
+ unsigned char high_char;
+ };
+
+static std::unordered_map<size_t, alphabet_state> alphabet_states;
+
+extern "C"
+void
+__gg__alphabet_create( cbl_encoding_t encoding,
+ size_t alphabet_index,
+ unsigned char *alphabet,
+ int low_char,
+ int high_char )
+ {
+ assert( encoding == custom_encoding_e );
+
+ std::unordered_map<size_t, alphabet_state>::const_iterator it =
+ alphabet_states.find(alphabet_index);
+
+ if( it == alphabet_states.end() )
+ {
+ alphabet_state new_state;
+ new_state.low_char = low_char;
+ new_state.high_char = high_char;
+
+ // Pass 1: Find the low and high ordinals:
+
+ int low = 256;
+ int high = -1;
+ for(int i=0; i<256; i++)
+ {
+ if( alphabet[i] != 0xFF )
+ {
+ low = std::min(low, (int)alphabet[i]);
+ high = std::max(high, (int)alphabet[i]);
+ }
+ }
+
+ assert(low == 0);
+
+ // Pass 2: Replace all 0xFF with something bigger than high:
+ for(int i=0; i<256; i++)
+ {
+ if( alphabet[i] == 0xFF )
+ {
+ new_state.collation[i] = ++high;
+ }
+ else
+ {
+ new_state.collation[i] = alphabet[i] ;
+ }
+ }
+ alphabet_states[alphabet_index] = new_state;
+ }
+
+ return;
+ }
+
+extern "C"
+void
+__gg__alphabet_use( cbl_encoding_t encoding,
+ size_t alphabet_index)
+ {
+ // We simply replace the values in the current program_state. If the
+ // state needs to be saved -- for example, if we are doing a SORT with an
+ // ALPHABET override -- that's up to the caller
+
+ switch( encoding )
+ {
+ case ASCII_e:
+ case iso646_e:
+ low_value_character = DEGENERATE_LOW_VALUE;
+ high_value_character = DEGENERATE_HIGH_VALUE;
+ if( internal_is_ebcdic )
+ {
+ program_states.back().rt_collation = __gg__one_to_one_values;
+ }
+ else
+ {
+ program_states.back().rt_collation = __gg__ebcdic_to_cp1252_collation;
+ }
+
+ break;
+
+ case EBCDIC_e:
+ low_value_character = DEGENERATE_LOW_VALUE;
+ high_value_character = DEGENERATE_HIGH_VALUE;
+ if( internal_is_ebcdic )
+ {
+ program_states.back().rt_collation = __gg__cp1252_to_ebcdic_collation;
+ }
+ else
+ {
+ program_states.back().rt_collation = __gg__one_to_one_values;
+ }
+ break;
+
+ case custom_encoding_e:
+ {
+ std::unordered_map<size_t, alphabet_state>::const_iterator it =
+ alphabet_states.find(alphabet_index);
+
+ assert( it != alphabet_states.end());
+ low_value_character = it->second.low_char;
+ high_value_character = it->second.high_char;
+ program_states.back().rt_collation = it->second.collation;
+ break;
+ }
+ }
+ return;
+ }
+
+extern "C"
+void
+__gg__ascii_to_internal_field(cblc_field_t *var)
+ {
+ ascii_to_internal_str((char *)var->data, var->capacity);
+ }
+
+extern "C"
+void
+__gg__ascii_to_internal(char *location, size_t length)
+ {
+ ascii_to_internal_str(location, length);
+ }
+
+extern "C"
+void
+__gg__console_to_internal(char *location, size_t length)
+ {
+ console_to_internal(location, length);
+ }
+
+extern "C"
+void
+__gg__parser_set_conditional(cblc_field_t *var, int figconst)
+ {
+ char special = internal_space;
+ switch(figconst)
+ {
+ case ascii_L:
+ special = ascii_to_internal(low_value_character);
+ break;
+ case ascii_H:
+ if( high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ special = high_value_character;
+ }
+ else
+ {
+ special = ascii_to_internal(high_value_character);
+ }
+ break;
+ case ascii_Z:
+ special = internal_zero;
+ break;
+ case ascii_Q:
+ special = ascii_to_internal(quote_character);
+ break;
+ }
+ memset( var->data, special, var->capacity);
+ }
+
+extern "C"
+void
+__gg__internal_to_console( char **dest, char *loc, size_t length)
+ {
+ *dest = internal_to_console(loc, length);
+ }
+
+extern "C"
+void
+__gg__internal_to_console_padded( char **dest, char *loc, size_t length)
+ {
+ *dest = internal_to_console(loc, length);
+ // This routine is used when it's possible -- as in a CALL BY REFERENCE --
+ // that the string might be replaced with another string that has more
+ // multi-byte UTF-8 codepoints than the original.
+ *dest = (char *)realloc(*dest, length*4);
+ }
+
+extern "C"
+void
+__gg__internal_to_console_in_place(char *loc, size_t length)
+ {
+ char *dest = internal_to_console(loc, length);
+ memcpy(loc, dest, length);
+ free(dest);
+ }
+
diff --git a/libgcobol/libobjc.def b/libgcobol/libobjc.def
deleted file mode 100644
index 0c7c2df1a7b7..000000000000
--- a/libgcobol/libobjc.def
+++ /dev/null
@@ -1,100 +0,0 @@
-; GNU Objective C Runtime DLL Export Definitions
-; Copyright (C) 1997-2022 Free Software Foundation, Inc.
-; Contributed by Scott Christley <scottc@net-community.com>
-;
-; This file is part of GCC.
-;
-; GCC 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, or (at your option) any later version.
-;
-; GCC 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
-; GCC; see the file COPYING3. If not, see <http://www.gnu.org/licenses/>.
-
-; FIXME: This file needs to be updated or removed
-
-LIBRARY libobjc
-EXPORTS
-search_for_method_in_list
-objc_get_uninstalled_dtable
-_objc_load_callback
-objc_malloc
-objc_atomic_malloc
-objc_realloc
-objc_calloc
-objc_free
-__objc_init_thread_system
-objc_mutex_allocate
-objc_mutex_deallocate
-objc_mutex_lock
-objc_mutex_trylock
-objc_mutex_unlock
-objc_thread_detach
-objc_thread_exit
-objc_thread_get_data
-objc_thread_get_priority
-objc_thread_id
-objc_thread_set_data
-objc_thread_set_priority
-objc_thread_yield
-objc_thread_add
-objc_thread_remove
-__objc_class_name_Object
-__objc_class_name_Protocol
-__objc_class_name_NXConstantString
-class_create_instance
-object_copy
-object_dispose
-__objc_init_selector_tables
-__objc_register_selectors_from_class
-__sel_register_typed_name
-sel_get_any_typed_uid
-sel_get_any_uid
-sel_get_name
-sel_get_type
-sel_get_typed_uid
-sel_get_uid
-sel_is_mapped
-sel_register_name
-sel_register_typed_name
-sel_types_match
-method_get_first_argument
-method_get_next_argument
-method_get_nth_argument
-method_get_number_of_arguments
-method_get_sizeof_arguments
-objc_aligned_size
-objc_alignof_type
-objc_get_type_qualifiers
-objc_promoted_size
-objc_sizeof_type
-objc_skip_argspec
-objc_skip_offset
-objc_skip_type_qualifiers
-objc_skip_typespec
-__objc_exec_class
-__objc_init_dispatch_tables
-__objc_install_premature_dtable
-__objc_print_dtable_stats
-__objc_update_dispatch_table_for_class
-class_add_method_list
-class_get_class_method
-class_get_instance_method
-get_imp
-nil_method
-objc_msg_lookup
-objc_msg_lookup_super
-objc_msg_sendv
-__objc_add_class_to_hash
-__objc_init_class_tables
-__objc_resolve_class_links
-class_pose_as
-objc_get_class
-objc_get_meta_class
-objc_lookup_class
-objc_next_class
diff --git a/libgcobol/linking.m b/libgcobol/linking.m
deleted file mode 100644
index 2915234b2bb2..000000000000
--- a/libgcobol/linking.m
+++ /dev/null
@@ -1,36 +0,0 @@
-/* Force linking of classes required by Objective C runtime.
- Copyright (C) 1997-2022 Free Software Foundation, Inc.
- Contributed by Ovidiu Predescu (ovidiu@net-community.com).
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include <objc/Object.h>
-
-/* Generate references to Object class since it is needed by the
- runtime system to run correctly. */
-
-void __objc_linking (void)
-{
- [Object class];
-}
-
diff --git a/libgcobol/memory.c b/libgcobol/memory.c
deleted file mode 100644
index 5cc51ad6b2bc..000000000000
--- a/libgcobol/memory.c
+++ /dev/null
@@ -1,134 +0,0 @@
-/* GNU Objective C Runtime Memory allocation functions
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* This file includes the standard functions for memory allocation and
- disposal. Users should use these functions in their ObjC programs
- so that they work properly with garbage collectors. */
-
-/* TODO: Turn these into macros or inline functions. */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-
-/* __USE_FIXED_PROTOTYPES__ used to be required to get prototypes for
- malloc, free, etc. on some platforms. It is unclear if we still
- need it, but it can't hurt. */
-#define __USE_FIXED_PROTOTYPES__
-#include <stdlib.h>
-
-#include "objc/runtime.h"
-
-#if OBJC_WITH_GC
-#include <gc/gc.h>
-
-void *
-objc_malloc (size_t size)
-{
- void *res = (void *)(GC_malloc (size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_atomic_malloc (size_t size)
-{
- void *res = (void *)(GC_malloc_atomic (size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_realloc (void *mem, size_t size)
-{
- void *res = (void *)(GC_realloc (mem, size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_calloc (size_t nelem, size_t size)
-{
- /* Note that GC_malloc returns cleared memory (see documentation) so
- there is no need to clear it. */
- void *res = (void *)(GC_malloc (nelem * size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void
-objc_free (void *mem __attribute__ ((__unused__)))
-{
- return;
-}
-
-#else
-
-void *
-objc_malloc (size_t size)
-{
- void *res = (void *)(malloc (size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_atomic_malloc (size_t size)
-{
- void *res = (void *)(malloc (size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_realloc (void *mem, size_t size)
-{
- void *res = (void *)(realloc (mem, size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void *
-objc_calloc (size_t nelem, size_t size)
-{
- void *res = (void *)(calloc (nelem, size));
- if (! res)
- _objc_abort ("Virtual memory exhausted\n");
- return res;
-}
-
-void
-objc_free (void *mem)
-{
- free (mem);
-}
-
-#endif /* !OBJC_WITH_GC */
diff --git a/libgcobol/methods.c b/libgcobol/methods.c
deleted file mode 100644
index 710ce38308fb..000000000000
--- a/libgcobol/methods.c
+++ /dev/null
@@ -1,177 +0,0 @@
-/* GNU Objective C Runtime method related functions.
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h" /* For runtime structures. */
-#include "objc/thr.h"
-#include "objc-private/runtime.h" /* For __objc_runtime_mutex. */
-#include <stdlib.h> /* For malloc. */
-
-SEL
-method_getName (struct objc_method * method)
-{
- if (method == NULL)
- return NULL;
-
- return method->method_name;
-}
-
-const char *
-method_getTypeEncoding (struct objc_method * method)
-{
- if (method == NULL)
- return NULL;
-
- return method->method_types;
-}
-
-IMP
-method_getImplementation (struct objc_method * method)
-{
- if (method == NULL)
- return NULL;
-
- return method->method_imp;
-}
-
-struct objc_method_description *
-method_getDescription (struct objc_method * method)
-{
- /* Note that the following returns NULL if method is NULL, which is
- fine. */
- return (struct objc_method_description *)method;
-}
-
-struct objc_method **
-class_copyMethodList (Class class_, unsigned int *numberOfReturnedMethods)
-{
- unsigned int count = 0;
- struct objc_method **returnValue = NULL;
- struct objc_method_list* method_list;
-
- if (class_ == Nil)
- {
- if (numberOfReturnedMethods)
- *numberOfReturnedMethods = 0;
- return NULL;
- }
-
- /* Lock the runtime mutex because the class methods may be
- concurrently modified. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Count how many methods we have. */
- method_list = class_->methods;
-
- while (method_list)
- {
- count = count + method_list->method_count;
- method_list = method_list->method_next;
- }
-
- if (count != 0)
- {
- unsigned int i = 0;
-
- /* Allocate enough memory to hold them. */
- returnValue
- = (struct objc_method **)(malloc (sizeof (struct objc_method *)
- * (count + 1)));
-
- /* Copy the methods. */
- method_list = class_->methods;
-
- while (method_list)
- {
- int j;
- for (j = 0; j < method_list->method_count; j++)
- {
- returnValue[i] = &(method_list->method_list[j]);
- i++;
- }
- method_list = method_list->method_next;
- }
-
- returnValue[i] = NULL;
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-
- if (numberOfReturnedMethods)
- *numberOfReturnedMethods = count;
-
- return returnValue;
-}
-
-IMP
-method_setImplementation (struct objc_method * method, IMP implementation)
-{
- IMP old_implementation;
-
- if (method == NULL || implementation == NULL)
- return NULL;
-
- /* We lock the runtime mutex so that concurrent calls to change the
- same method won't conflict with each other. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- old_implementation = method->method_imp;
- method->method_imp = implementation;
-
- /* That was easy :-). But now we need to find all classes that use
- this method, and update the IMP in the dispatch tables. */
- __objc_update_classes_with_methods (method, NULL);
-
- objc_mutex_unlock (__objc_runtime_mutex);
-
- return old_implementation;
-}
-
-void
-method_exchangeImplementations (struct objc_method * method_a, struct objc_method * method_b)
-{
- IMP old_implementation_a;
- IMP old_implementation_b;
-
- if (method_a == NULL || method_b == NULL)
- return;
-
- /* We lock the runtime mutex so that concurrent calls to exchange
- similar methods won't conflict with each other. Each of them
- should be atomic. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- old_implementation_a = method_a->method_imp;
- old_implementation_b = method_b->method_imp;
-
- method_a->method_imp = old_implementation_b;
- method_b->method_imp = old_implementation_a;
-
- /* That was easy :-). But now we need to find all classes that use
- these methods, and update the IMP in the dispatch tables. */
- __objc_update_classes_with_methods (method_a, method_b);
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
diff --git a/libgcobol/nil_method.c b/libgcobol/nil_method.c
deleted file mode 100644
index d909b5114c79..000000000000
--- a/libgcobol/nil_method.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/* GNU Objective C Runtime nil receiver function
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-
-/* This is the nil method, the function that is called when the receiver
- of a method is nil */
-
-#include "objc-private/common.h"
-#include "objc/objc.h"
-
-/* When the receiver of a method invocation is nil, the runtime
- returns nil_method() as the method implementation. This function
- will be casted to whatever function was supposed to be executed to
- execute that method (that function will take an id, followed by a
- SEL, followed by who knows what arguments, depends on the method),
- and executed.
-
- For this reason, nil_method() should be a function which can be
- called in place of any function taking an 'id' argument followed by
- a 'SEL' argument, followed by zero, or one, or any number of
- arguments (both a fixed number, or a variable number !).
-
- There is no "proper" implementation of such a nil_method function
- in C, however in all existing implementations it does not matter
- when extra arguments are present, so we can simply create a function
- taking a receiver and a selector, and all other arguments will be
- ignored. :-)
-*/
-
-id
-nil_method (id receiver, SEL op __attribute__ ((__unused__)))
-{
- return receiver;
-}
diff --git a/libgcobol/objc-foreach.c b/libgcobol/objc-foreach.c
deleted file mode 100644
index f627771b96e1..000000000000
--- a/libgcobol/objc-foreach.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/* GNU Objective C Runtime 'fast enumeration' implementation
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* This file implements objc_enumeration_mutation() and
- objc_set_enumeration_mutation_handler(), the two functions required
- to handle mutations during a fast enumeration. */
-#include "objc-private/common.h"
-#include "objc-private/error.h" /* For _objc_abort() */
-#include "objc/runtime.h" /* For objc_enumerationMutation() and objc_set_enumeration_mutation_handler() */
-
-/* The enumeration mutation handler currently in use. */
-static void (*__objc_enumeration_mutation_handler)(id) = NULL;
-
-void
-objc_setEnumerationMutationHandler (void (*handler)(id))
-{
- __objc_enumeration_mutation_handler = handler;
-}
-
-void
-objc_enumerationMutation (id collection)
-{
- if (__objc_enumeration_mutation_handler != NULL)
- (*__objc_enumeration_mutation_handler) (collection);
-
- /* We always abort if we get here; there is no point in going on as
- the next iteration in the fast enumeration would probably go
- deeply wrong. */
- _objc_abort ("Collection %p mutated during fast enumeration", collection);
-}
diff --git a/libgcobol/objc-private/README b/libgcobol/objc-private/README
deleted file mode 100644
index cce1d041675c..000000000000
--- a/libgcobol/objc-private/README
+++ /dev/null
@@ -1,4 +0,0 @@
-This directory contains headers that are private to the runtime and
-that are only included while the runtime is being compiled. They are
-not installed, so developers using the library can't actually even see
-them.
diff --git a/libgcobol/objc-private/accessors.h b/libgcobol/objc-private/accessors.h
deleted file mode 100644
index 77b5db942ff9..000000000000
--- a/libgcobol/objc-private/accessors.h
+++ /dev/null
@@ -1,32 +0,0 @@
-/* GNU Objective C Runtime accessors - Private Declarations
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_accessors_INCLUDE_GNU
-#define __objc_private_accessors_INCLUDE_GNU
-
-/* This function needs to be called at startup by init.c. */
-void
-__objc_accessors_init (void);
-
-#endif /* not __objc_private_accessors_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/common.h b/libgcobol/objc-private/common.h
deleted file mode 100644
index 2a9dab21482e..000000000000
--- a/libgcobol/objc-private/common.h
+++ /dev/null
@@ -1,44 +0,0 @@
-/* GNU Objective C Runtime Common Private Definitions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_common_INCLUDE_GNU
-#define __objc_private_common_INCLUDE_GNU
-
-/* This file contains definitions that should be included by all .c
- and .m files in libobjc. */
-
-/* When debugging libobjc, add
-
- #define DEBUG 1
-
- at the very beginning of a file in libobjc (before including this file) to turn
- on DEBUG_PRINTF(). */
-#ifdef DEBUG
-#include <stdio.h>
-#define DEBUG_PRINTF(format, args...) printf (format, ## args)
-#else
-#define DEBUG_PRINTF(format, args...)
-#endif
-
-#endif /* __objc_private_common_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/error.h b/libgcobol/objc-private/error.h
deleted file mode 100644
index 01bb3d2683f0..000000000000
--- a/libgcobol/objc-private/error.h
+++ /dev/null
@@ -1,38 +0,0 @@
-/* GNU Objective C Runtime Common Private Definitions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_error_INCLUDE_GNU
-#define __objc_private_error_INCLUDE_GNU
-
-/* Prints an unrecoverable error to stderr, then aborts the program.
- This should only be used for errors that really are unrecorevable:
- failure to allocate memory, and failure to load an Objective-C
- module. All other usages of this function should be converted into
- some milder type of error (unless aborting is explicitly required
- by the documentation/API).
-*/
-void
-_objc_abort (const char *fmt, ...) __attribute__ ((noreturn));
-
-#endif /* __objc_private_error_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/hash.h b/libgcobol/objc-private/hash.h
deleted file mode 100644
index c3abae849f39..000000000000
--- a/libgcobol/objc-private/hash.h
+++ /dev/null
@@ -1,201 +0,0 @@
-/* Hash tables for Objective C method dispatch.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* You need to include this file after including objc.h */
-
-#ifndef __hash_INCLUDE_GNU
-#define __hash_INCLUDE_GNU
-
-#include <stddef.h>
-#include <string.h>
-
-/*
- * This data structure is used to hold items
- * stored in a hash table. Each node holds
- * a key/value pair.
- *
- * Items in the cache are really of type void *.
- */
-typedef struct cache_node
-{
- struct cache_node *next; /* Pointer to next entry on the list.
- NULL indicates end of list. */
- const void *key; /* Key used to locate the value. Used
- to locate value when more than one
- key computes the same hash
- value. */
- void *value; /* Value stored for the key. */
-} *node_ptr;
-
-
-/*
- * This data type is the function that computes a hash code given a key.
- * Therefore, the key can be a pointer to anything and the function specific
- * to the key type.
- *
- * Unfortunately there is a mutual data structure reference problem with this
- * typedef. Therefore, to remove compiler warnings the functions passed to
- * objc_hash_new will have to be casted to this type.
- */
-typedef unsigned int (*hash_func_type) (void *, const void *);
-
-/*
- * This data type is the function that compares two hash keys and returns an
- * integer greater than, equal to, or less than 0, according as the first
- * parameter is lexicographically greater than, equal to, or less than the
- * second.
- */
-
-typedef int (*compare_func_type) (const void *, const void *);
-
-
-/*
- * This data structure is the cache.
- *
- * It must be passed to all of the hashing routines
- * (except for new).
- */
-typedef struct cache
-{
- /* Variables used to implement the hash itself. */
- node_ptr *node_table; /* Pointer to an array of hash nodes. */
- /* Variables used to track the size of the hash table so to determine
- when to resize it. */
- unsigned int size; /* Number of buckets allocated for the hash table
- (number of array entries allocated for
- "node_table"). Must be a power of two. */
- unsigned int used; /* Current number of entries in the hash table. */
- unsigned int mask; /* Precomputed mask. */
-
- /* Variables used to implement indexing through the hash table. */
-
- unsigned int last_bucket; /* Tracks which entry in the array where
- the last value was returned. */
- /* Function used to compute a hash code given a key.
- This function is specified when the hash table is created. */
- hash_func_type hash_func;
- /* Function used to compare two hash keys to see if they are equal. */
- compare_func_type compare_func;
-} *cache_ptr;
-
-
-/* Allocate and initialize a hash table. */
-
-cache_ptr objc_hash_new (unsigned int size,
- hash_func_type hash_func,
- compare_func_type compare_func);
-
-/* Deallocate all of the hash nodes and the cache itself. */
-
-void objc_hash_delete (cache_ptr cache);
-
-/* Add the key/value pair to the hash table. If the
- hash table reaches a level of fullness then it will be resized.
-
- assert if the key is already in the hash. */
-
-void objc_hash_add (cache_ptr *cachep, const void *key, void *value);
-
-/* Remove the key/value pair from the hash table.
- assert if the key isn't in the table. */
-
-void objc_hash_remove (cache_ptr cache, const void *key);
-
-/* Used to index through the hash table. Start with NULL
- to get the first entry.
-
- Successive calls pass the value returned previously.
- ** Don't modify the hash during this operation ***
-
- Cache nodes are returned such that key or value can
- be extracted. */
-
-node_ptr objc_hash_next (cache_ptr cache, node_ptr node);
-
-/* Used to return a value from a hash table using a given key. */
-
-void *objc_hash_value_for_key (cache_ptr cache, const void *key);
-
-/* Used to determine if the given key exists in the hash table */
-
-BOOL objc_hash_is_key_in_hash (cache_ptr cache, const void *key);
-
-/************************************************
-
- Useful hashing functions.
-
- Declared inline for your pleasure.
-
-************************************************/
-
-/* Calculate a hash code by performing some
- manipulation of the key pointer. (Use the lowest bits
- except for those likely to be 0 due to alignment.) */
-
-static inline unsigned int
-objc_hash_ptr (cache_ptr cache, const void *key)
-{
- return ((size_t)key / sizeof (void *)) & cache->mask;
-}
-
-
-/* Calculate a hash code by iterating over a NULL
- terminate string. */
-static inline unsigned int
-objc_hash_string (cache_ptr cache, const void *key)
-{
- unsigned int ret = 0;
- unsigned int ctr = 0;
- const char *ckey = (const char *) key;
-
- while (*ckey) {
- ret ^= *ckey++ << ctr;
- ctr = (ctr + 1) % sizeof (void *);
- }
-
- return ret & cache->mask;
-}
-
-
-/* Compare two pointers for equality. */
-static inline int
-objc_compare_ptrs (const void *k1, const void *k2)
-{
- return (k1 == k2);
-}
-
-
-/* Compare two strings. */
-static inline int
-objc_compare_strings (const void *k1, const void *k2)
-{
- if (k1 == k2)
- return 1;
- else if (k1 == 0 || k2 == 0)
- return 0;
- else
- return ! strcmp ((const char *) k1, (const char *) k2);
-}
-
-#endif /* not __hash_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/module-abi-8.h b/libgcobol/objc-private/module-abi-8.h
deleted file mode 100644
index 4edcd9da376b..000000000000
--- a/libgcobol/objc-private/module-abi-8.h
+++ /dev/null
@@ -1,307 +0,0 @@
-/* Definitions of Module Structures used by ABI version 8
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_module_abi_8_INCLUDE_GNU
-#define __objc_private_module_abi_8_INCLUDE_GNU
-
-/* For every class which happens to have statically allocated instances in
- this module, one OBJC_STATIC_INSTANCES is allocated by the compiler.
- INSTANCES is NULL terminated and points to all statically allocated
- instances of this class. */
-struct objc_static_instances
-{
- char *class_name;
-#ifdef __cplusplus
- id instances[1];
-#else
- id instances[0];
-#endif
-};
-
-/* Whereas a Module (defined further down) is the root (typically) of a file,
- a Symtab is the root of the class and category definitions within the
- module.
-
- A Symtab contains a variable length array of pointers to classes and
- categories defined in the module. */
-struct objc_symtab
-{
- unsigned long sel_ref_cnt; /* Unused (always set to 0). */
- struct objc_selector *refs; /* The table of selectors referenced in
- this module. This is terminated by a
- selector with NULL sel_id and NULL
- sel_types. Note that we use the type
- 'struct objc_selector *' and not
- 'SEL' (which is 'const struct
- objc_selector *') because the sel_id
- of these selectors is patched up by
- the runtime when the module is
- loaded. */
- unsigned short cls_def_cnt; /* Number of classes compiled (defined)
- in the module. */
- unsigned short cat_def_cnt; /* Number of categories compiled
- (defined) in the module. */
- void *defs[1]; /* Variable array of pointers.
- cls_def_cnt of type Class followed by
- cat_def_cnt of type Category_t,
- followed by a NULL terminated array
- of objc_static_instances. */
-};
-
-/* The compiler generates one of these structures for each module that
- composes the executable (eg main.m).
-
- This data structure is the root of the definition tree for the
- module.
-
- A collect program runs between ld stages and creates a ObjC ctor
- array. That array holds a pointer to each module structure of the
- executable. */
-struct objc_module
-{
- unsigned long version; /* Version of the Module data
- structure. */
- unsigned long size; /* sizeof(Module) according to the
- compiler - only used to sanity check
- that it matches sizeof(Module)
- according to the runtime. */
- const char* name; /* Name of the file used to compile the
- module - not set by modern compilers
- for security reasons. */
- struct objc_symtab *symtab; /* Pointer to the Symtab of the module.
- The Symtab holds an array of pointers
- to the classes and categories defined
- in the module. */
-};
-
-/* The compiler generates one of these structures for a class that has
- instance variables defined in its specification. */
-struct objc_ivar
-{
- const char* ivar_name; /* Name of the instance variable as entered
- in the class definition. */
- const char* ivar_type; /* Description of the Ivar's type. Useful
- for debuggers. */
- int ivar_offset; /* Byte offset from the base address of the
- instance structure to the variable. */
-};
-
-struct objc_ivar_list
-{
- int ivar_count; /* Number of structures (Ivar)
- contained in the list. One
- structure per instance variable
- defined in the class. */
- struct objc_ivar ivar_list[1]; /* Variable length structure. */
-};
-
-/* The compiler generates one (or more) of these structures for a
- class that has methods defined in its specification.
-
- The implementation of a class can be broken into separate pieces in
- a file and categories can break them across modules. To handle this
- problem is a singly linked list of methods. */
-struct objc_method
-{
- SEL method_name; /* This variable is the method's name.
- The compiler puts a char* here, and
- it's replaced by a real SEL at runtime
- when the method is registered. */
- const char* method_types; /* Description of the method's parameter
- list. Used when registering the
- selector with the runtime. When that
- happens, method_name will contain the
- method's parameter list. */
- IMP method_imp; /* Address of the method in the
- executable. */
-};
-
-struct objc_method_list
-{
- struct objc_method_list* method_next; /* This variable is used to
- link a method list to
- another. It is a singly
- linked list. */
- int method_count; /* Number of methods defined
- in this structure. */
- struct objc_method method_list[1]; /* Variable length
- structure. */
-};
-
-/* Note that a 'struct objc_method_description' as embedded inside a
- Protocol uses the same trick as a 'struct objc_method': the
- method_name is a 'char *' according to the compiler, who puts the
- method name as a string in there. At runtime, the selectors need
- to be registered, and the method_name then becomes a SEL. */
-struct objc_method_description_list
-{
- int count;
- struct objc_method_description list[1];
-};
-
-struct objc_protocol {
- struct objc_class* class_pointer;
- char *protocol_name;
- struct objc_protocol_list *protocol_list;
- struct objc_method_description_list *instance_methods, *class_methods;
-};
-
-
-struct objc_protocol_list
-{
- struct objc_protocol_list *next;
- size_t count;
- struct objc_protocol *list[1];
-};
-
-/*
- The compiler generates one of these structures for each class.
-
- This structure is the definition for classes.
-
- This structure is generated by the compiler in the executable and
- used by the run-time during normal messaging operations. Therefore
- some members change type. The compiler generates "char* const" and
- places a string in the following member variables: super_class.
-*/
-struct objc_class {
- struct objc_class* class_pointer; /* Pointer to the class's meta
- class. */
- struct objc_class* super_class; /* Pointer to the super
- class. NULL for class
- Object. */
- const char* name; /* Name of the class. */
- long version; /* Unknown. */
- unsigned long info; /* Bit mask. See class masks
- defined below. */
- long instance_size; /* Size in bytes of the class.
- The sum of the class
- definition and all super
- class definitions. */
-#ifdef _WIN64
- /* We pad the structure manually to prevent warning when -Wpadded is
- used. The compiler automatically pads the structures that it
- generates, so this manually padded structure still matches the
- one generated by the compiler, but if we don't pad manually,
- -Wpadded detects that padding is being added and generates
- annoying warnings. This hack is necessary as on LLP64 targets
- sizeof (long) isn't equal to sizeof (void *). */
- long pad;
-#endif
- struct objc_ivar_list* ivars; /* Pointer to a structure that
- describes the instance
- variables in the class
- definition. NULL indicates
- no instance variables.
- Does not include super
- class variables. */
- struct objc_method_list* methods; /* Linked list of instance
- methods defined for the
- class. */
- struct sarray * dtable; /* Pointer to instance method
- dispatch table. */
- struct objc_class* subclass_list; /* Subclasses */
- struct objc_class* sibling_class;
-
- struct objc_protocol_list *protocols; /* Protocols conformed to */
- void* gc_object_type;
-};
-
-/* This is used to assure consistent access to the info field of
- classes. */
-#ifndef HOST_BITS_PER_LONG
-# define HOST_BITS_PER_LONG (sizeof(long)*8)
-#endif
-
-#define __CLS_INFO(cls) ((cls)->info)
-#define __CLS_ISINFO(cls, mask) ((__CLS_INFO(cls)&mask)==mask)
-#define __CLS_SETINFO(cls, mask) (__CLS_INFO(cls) |= mask)
-#define __CLS_SETNOTINFO(cls, mask) (__CLS_INFO(cls) &= ~mask)
-
-/* The structure is of type MetaClass */
-#define _CLS_META 0x2L
-#define CLS_ISMETA(cls) ((cls)&&__CLS_ISINFO(cls, _CLS_META))
-
-/* The structure is of type Class */
-#define _CLS_CLASS 0x1L
-#define CLS_ISCLASS(cls) ((cls)&&__CLS_ISINFO(cls, _CLS_CLASS))
-
-/* The class is initialized within the runtime. This means that it
- has had correct super and sublinks assigned. */
-#define _CLS_RESOLV 0x8L
-#define CLS_ISRESOLV(cls) __CLS_ISINFO(cls, _CLS_RESOLV)
-#define CLS_SETRESOLV(cls) __CLS_SETINFO(cls, _CLS_RESOLV)
-
-/* The class has been send a +initialize message or a such is not
- defined for this class. */
-#define _CLS_INITIALIZED 0x04L
-#define CLS_ISINITIALIZED(cls) __CLS_ISINFO(cls, _CLS_INITIALIZED)
-#define CLS_SETINITIALIZED(cls) __CLS_SETINFO(cls, _CLS_INITIALIZED)
-
-/* The class is being constructed; it has been allocated using
- objc_allocateClassPair(), but has not been registered yet by using
- objc_registerClassPair(). This means it is possible to freely add
- instance variables to the class, but it can't be used for anything
- yet. */
-#define _CLS_IN_CONSTRUCTION 0x10L
-#define CLS_IS_IN_CONSTRUCTION(cls) __CLS_ISINFO(cls, _CLS_IN_CONSTRUCTION)
-#define CLS_SET_IN_CONSTRUCTION(cls) __CLS_SETINFO(cls, _CLS_IN_CONSTRUCTION)
-#define CLS_SET_NOT_IN_CONSTRUCTION(cls) __CLS_SETNOTINFO(cls, _CLS_IN_CONSTRUCTION)
-
-/* The class number of this class. This must be the same for both the
- class and its meta class object. */
-#define CLS_GETNUMBER(cls) (__CLS_INFO(cls) >> (HOST_BITS_PER_LONG/2))
-#define CLS_SETNUMBER(cls, num) \
- ({ (cls)->info <<= (HOST_BITS_PER_LONG/2); \
- (cls)->info >>= (HOST_BITS_PER_LONG/2); \
- __CLS_SETINFO(cls, (((unsigned long)num) << (HOST_BITS_PER_LONG/2))); })
-
-/* The compiler generates one of these structures for each category.
- A class may have many categories and contain both instance and
- factory methods. */
-struct objc_category
-{
- const char* category_name; /* Name of the category.
- Name contained in the
- () of the category
- definition. */
- const char* class_name; /* Name of the class to
- which the category
- belongs. */
- struct objc_method_list *instance_methods; /* Linked list of
- instance methods
- defined in the
- category. NULL
- indicates no instance
- methods defined. */
- struct objc_method_list *class_methods; /* Linked list of
- factory methods
- defined in the
- category. NULL
- indicates no class
- methods defined. */
- struct objc_protocol_list *protocols; /* List of Protocols
- conformed to. */
-};
-
-#endif /* __objc_private_module_abi_8_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/objc-list.h b/libgcobol/objc-private/objc-list.h
deleted file mode 100644
index 7e93b1743bf0..000000000000
--- a/libgcobol/objc-private/objc-list.h
+++ /dev/null
@@ -1,94 +0,0 @@
-/* Generic single linked list to keep various information
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __GNU_OBJC_LIST_H
-#define __GNU_OBJC_LIST_H
-
-struct objc_list
-{
- void *head;
- struct objc_list *tail;
-};
-
-/* Return a cons cell produced from (head . tail). */
-static inline struct objc_list*
-list_cons (void* head, struct objc_list* tail)
-{
- struct objc_list* cell;
-
- cell = (struct objc_list*)objc_malloc (sizeof (struct objc_list));
- cell->head = head;
- cell->tail = tail;
- return cell;
-}
-
-/* Remove the element at the head by replacing it by its
- successor. */
-static inline void
-list_remove_head (struct objc_list** list)
-{
- if ((*list)->tail)
- {
- /* Fetch next. */
- struct objc_list* tail = (*list)->tail;
-
- /* Copy next to list head. */
- *(*list) = *tail;
-
- /* Free next. */
- objc_free (tail);
- }
- else
- {
- /* Inly one element in list. */
- objc_free (*list);
- (*list) = 0;
- }
-}
-
-
-/* Map FUNCTION over all elements in LIST. */
-static inline void
-list_mapcar (struct objc_list* list, void(*function)(void*))
-{
- while (list)
- {
- (*function) (list->head);
- list = list->tail;
- }
-}
-
-/* Free list (backwards recursive). */
-static inline void
-list_free (struct objc_list* list)
-{
- if(list)
- {
- list_free (list->tail);
- objc_free (list);
- }
-}
-
-#endif /* not __GNU_OBJC_LIST_H */
diff --git a/libgcobol/objc-private/objc-sync.h b/libgcobol/objc-private/objc-sync.h
deleted file mode 100644
index 45f0af6e2859..000000000000
--- a/libgcobol/objc-private/objc-sync.h
+++ /dev/null
@@ -1,33 +0,0 @@
-/* GNU Objective C Runtime @synchronized implementation - Private functions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_objc_sync_INCLUDE_GNU
-#define __objc_private_objc_sync_INCLUDE_GNU
-
-/* This function needs to be called at startup before @synchronized()
- can be used. */
-void
-__objc_sync_init (void);
-
-#endif /* not __objc_private_objc_sync_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/protocols.h b/libgcobol/objc-private/protocols.h
deleted file mode 100644
index 7d73f7d496a1..000000000000
--- a/libgcobol/objc-private/protocols.h
+++ /dev/null
@@ -1,38 +0,0 @@
-/* GNU Objective C Runtime protocols - Private functions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_protocols_INCLUDE_GNU
-#define __objc_private_protocols_INCLUDE_GNU
-
-/* This function needs to be called at startup by init.c. */
-void
-__objc_protocols_init (void);
-
-/* This function adds a protocol to the internal hashtable of
- protocols by name, which allows objc_getProtocol(name) to be
- implemented efficiently. */
-void
-__objc_protocols_add_protocol (const char *name, struct objc_protocol *object);
-
-#endif /* not __objc_private_protocols_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/runtime.h b/libgcobol/objc-private/runtime.h
deleted file mode 100644
index 711b21cf6087..000000000000
--- a/libgcobol/objc-private/runtime.h
+++ /dev/null
@@ -1,76 +0,0 @@
-/* GNU Objective C Runtime internal declarations
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* You need to include this file after including a number of standard ObjC files.
-
-The original list was:
-
-#include "objc/objc.h"
-#include "objc/objc-api.h"
-#include "objc/thr.h"
-#include "objc/hash.h"
-#include "objc/objc-list.h"
-
-but can almost certainly be shrunk down. */
-
-#ifndef __objc_private_runtime_INCLUDE_GNU
-#define __objc_private_runtime_INCLUDE_GNU
-
-#include <stdarg.h> /* for varargs and va_list's */
-
-#include <stdio.h>
-#include <ctype.h>
-
-#include <stddef.h> /* so no one else will get system versions */
-#include <assert.h>
-
-extern BOOL __objc_add_class_to_hash (Class); /* (objc-class.c) */
-extern void __objc_init_class_tables (void); /* (objc-class.c) */
-extern void __objc_init_dispatch_tables (void); /* (objc-dispatch.c) */
-extern void __objc_install_premature_dtable (Class); /* (objc-dispatch.c) */
-extern void __objc_resolve_class_links (void); /* (objc-class.c) */
-extern void __objc_update_dispatch_table_for_class (Class);/* (objc-msg.c) */
-
-extern int __objc_init_thread_system (void); /* thread.c */
-extern int __objc_fini_thread_system (void); /* thread.c */
-extern BOOL __objc_init_class (Class class); /* init.c */
-extern void class_add_method_list (Class, struct objc_method_list *);
-
-/* Registering instance methods as class methods for root classes */
-extern void __objc_register_instance_methods_to_class (Class);
-extern struct objc_method * search_for_method_in_list (struct objc_method_list * list, SEL op);
-
-extern void
-__objc_update_classes_with_methods (struct objc_method *method_a, struct objc_method *method_b); /* class.c */
-
-/* Mutex locking __objc_selector_max_index and its arrays. */
-extern objc_mutex_t __objc_runtime_mutex;
-
-/* Number of threads which are alive. */
-extern int __objc_runtime_threads_alive;
-
-BOOL __objc_responds_to (id object, SEL sel); /* for internal use only! */
-extern void __objc_generate_gc_type_description (Class);
-
-#endif /* not __objc_private_runtime_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/sarray.h b/libgcobol/objc-private/sarray.h
deleted file mode 100644
index be7187c72278..000000000000
--- a/libgcobol/objc-private/sarray.h
+++ /dev/null
@@ -1,243 +0,0 @@
-/* Sparse Arrays for Objective C dispatch tables
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __sarray_INCLUDE_GNU
-#define __sarray_INCLUDE_GNU
-
-#define OBJC_SPARSE2 /* 2-level sparse array. */
-/* #define OBJC_SPARSE3 */ /* 3-level sparse array. */
-
-#ifdef OBJC_SPARSE2
-extern const char* __objc_sparse2_id;
-#endif
-
-#ifdef OBJC_SPARSE3
-extern const char* __objc_sparse3_id;
-#endif
-
-#include <stddef.h>
-
-extern int nbuckets; /* for stats */
-extern int nindices;
-extern int narrays;
-extern int idxsize;
-
-/* An unsigned integer of same size as a pointer. */
-#define SIZET_BITS (sizeof (size_t) * 8)
-
-#if defined (__sparc__) || defined (OBJC_SPARSE2)
-#define PRECOMPUTE_SELECTORS
-#endif
-
-#ifdef OBJC_SPARSE3
-
-/* Buckets are 8 words each. */
-#define BUCKET_BITS 3
-#define BUCKET_SIZE (1 << BUCKET_BITS)
-#define BUCKET_MASK (BUCKET_SIZE - 1)
-
-/* Indices are 16 words each. */
-#define INDEX_BITS 4
-#define INDEX_SIZE (1 << INDEX_BITS)
-#define INDEX_MASK (INDEX_SIZE - 1)
-
-#define INDEX_CAPACITY (BUCKET_SIZE * INDEX_SIZE)
-
-#else /* OBJC_SPARSE2 */
-
-/* Buckets are 32 words each. */
-#define BUCKET_BITS 5
-#define BUCKET_SIZE (1 << BUCKET_BITS)
-#define BUCKET_MASK (BUCKET_SIZE - 1)
-
-#endif /* OBJC_SPARSE2 */
-
-typedef size_t sidx;
-
-#ifdef PRECOMPUTE_SELECTORS
-
-struct soffset
-{
-#ifdef OBJC_SPARSE3
- unsigned int unused : SIZET_BITS / 4;
- unsigned int eoffset : SIZET_BITS / 4;
- unsigned int boffset : SIZET_BITS / 4;
- unsigned int ioffset : SIZET_BITS / 4;
-#else /* OBJC_SPARSE2 */
-#ifdef __sparc__
- unsigned long boffset : (SIZET_BITS - 2) - BUCKET_BITS;
- unsigned int eoffset : BUCKET_BITS;
- unsigned int unused : 2;
-#else
- unsigned int boffset : SIZET_BITS / 2;
- unsigned int eoffset : SIZET_BITS / 2;
-#endif
-#endif /* OBJC_SPARSE2 */
-};
-
-union sofftype
-{
- struct soffset off;
- sidx idx;
-};
-
-#endif /* not PRECOMPUTE_SELECTORS */
-
-union sversion
-{
- int version;
- void *next_free;
-};
-
-struct sbucket
-{
- /* Elements stored in array. */
- void* elems[BUCKET_SIZE];
-
- /* Used for copy-on-write. */
- union sversion version;
-};
-
-#ifdef OBJC_SPARSE3
-
-struct sindex
-{
- struct sbucket* buckets[INDEX_SIZE];
-
- /* Used for copy-on-write. */
- union sversion version;
-};
-
-#endif /* OBJC_SPARSE3 */
-
-struct sarray
-{
-#ifdef OBJC_SPARSE3
- struct sindex** indices;
- struct sindex* empty_index;
-#else /* OBJC_SPARSE2 */
- struct sbucket** buckets;
-#endif /* OBJC_SPARSE2 */
- struct sbucket* empty_bucket;
-
- /* Used for copy-on-write. */
- union sversion version;
-
- short ref_count;
- struct sarray* is_copy_of;
- size_t capacity;
-};
-
-struct sarray* sarray_new (int, void* default_element);
-void sarray_free (struct sarray*);
-struct sarray* sarray_lazy_copy (struct sarray*);
-void sarray_realloc (struct sarray*, int new_size);
-void sarray_at_put (struct sarray*, sidx indx, void* elem);
-void sarray_at_put_safe (struct sarray*, sidx indx, void* elem);
-
-struct sarray* sarray_hard_copy (struct sarray*); /* ... like the name ? */
-void sarray_remove_garbage (void);
-
-
-#ifdef PRECOMPUTE_SELECTORS
-/* Transform soffset values to ints and vice versa. */
-static inline unsigned int
-soffset_decode (sidx indx)
-{
- union sofftype x;
- x.idx = indx;
-#ifdef OBJC_SPARSE3
- return x.off.eoffset
- + (x.off.boffset * BUCKET_SIZE)
- + (x.off.ioffset * INDEX_CAPACITY);
-#else /* OBJC_SPARSE2 */
- return x.off.eoffset + (x.off.boffset * BUCKET_SIZE);
-#endif /* OBJC_SPARSE2 */
-}
-
-static inline sidx
-soffset_encode (size_t offset)
-{
- union sofftype x;
- x.off.eoffset = offset % BUCKET_SIZE;
-#ifdef OBJC_SPARSE3
- x.off.boffset = (offset / BUCKET_SIZE) % INDEX_SIZE;
- x.off.ioffset = offset / INDEX_CAPACITY;
-#else /* OBJC_SPARSE2 */
- x.off.boffset = offset / BUCKET_SIZE;
-#endif
- return (sidx)x.idx;
-}
-
-#else /* not PRECOMPUTE_SELECTORS */
-
-static inline size_t
-soffset_decode (sidx indx)
-{
- return indx;
-}
-
-static inline sidx
-soffset_encode (size_t offset)
-{
- return offset;
-}
-#endif /* not PRECOMPUTE_SELECTORS */
-
-/* Get element from the Sparse array `array' at offset `indx'. */
-static inline void* sarray_get (struct sarray* array, sidx indx)
-{
-#ifdef PRECOMPUTE_SELECTORS
- union sofftype x;
- x.idx = indx;
-#ifdef OBJC_SPARSE3
- return array->
- indices[x.off.ioffset]->
- buckets[x.off.boffset]->
- elems[x.off.eoffset];
-#else /* OBJC_SPARSE2 */
- return array->buckets[x.off.boffset]->elems[x.off.eoffset];
-#endif /* OBJC_SPARSE2 */
-#else /* not PRECOMPUTE_SELECTORS */
-#ifdef OBJC_SPARSE3
- return array->
- indices[indx / INDEX_CAPACITY]->
- buckets[(indx / BUCKET_SIZE) % INDEX_SIZE]->
- elems[indx % BUCKET_SIZE];
-#else /* OBJC_SPARSE2 */
- return array->buckets[indx / BUCKET_SIZE]->elems[indx % BUCKET_SIZE];
-#endif /* not OBJC_SPARSE3 */
-#endif /* not PRECOMPUTE_SELECTORS */
-}
-
-static inline void* sarray_get_safe (struct sarray* array, sidx indx)
-{
- if (soffset_decode (indx) < array->capacity)
- return sarray_get (array, indx);
- else
- return (array->empty_bucket->elems[0]);
-}
-
-#endif /* __sarray_INCLUDE_GNU */
diff --git a/libgcobol/objc-private/selector.h b/libgcobol/objc-private/selector.h
deleted file mode 100644
index a1457e1dc60c..000000000000
--- a/libgcobol/objc-private/selector.h
+++ /dev/null
@@ -1,75 +0,0 @@
-/* GNU Objective C Runtime selector implementation - Private functions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_private_selector_INCLUDE_GNU
-#define __objc_private_selector_INCLUDE_GNU
-
-/* Private runtime functions that may go away or be rewritten or
- replaced. */
-
-/* Definition of a selector. Selectors themselves are not unique, but
- the sel_id is a unique identifier. */
-struct objc_selector
-{
- void *sel_id;
- const char *sel_types;
-};
-
-/* An inline, fast version of sel_isEqual(). */
-inline static BOOL
-sel_eq (SEL s1, SEL s2)
-{
- if (s1 == 0 || s2 == 0)
- return s1 == s2;
- else
- return s1->sel_id == s2->sel_id;
-}
-
-/* Number of selectors stored in each of the selector tables. */
-extern unsigned int __objc_selector_max_index;
-
-/* Initialize the selector tables. This must be called by init.c. */
-void __objc_init_selector_tables(void);
-
-/* Various private functions to register selectors. */
-void __objc_register_selectors_from_class(Class);
-void __objc_register_selectors_from_list (struct objc_method_list *);
-void __objc_register_selectors_from_description_list
-(struct objc_method_description_list *method_list);
-void __objc_register_selectors_from_module (struct objc_selector *selectors);
-
-/* Return whether a selector is mapped or not ("mapped" meaning that
- it has been inserted into the selector table). This is private as
- only the runtime should ever encounter or need to know about
- unmapped selectors. */
-BOOL sel_is_mapped (SEL aSel);
-
-/* Return selector representing name without registering it if it
- doesn't exist. Typically used internally by the runtime when it's
- looking up methods that may or may not exist (such as +initialize)
- in the most efficient way. */
-SEL
-sel_get_any_uid (const char *name);
-
-#endif /* not __objc_private_selector_INCLUDE_GNU */
diff --git a/libgcobol/objc-sync.c b/libgcobol/objc-sync.c
deleted file mode 100644
index ba534f02b25f..000000000000
--- a/libgcobol/objc-sync.c
+++ /dev/null
@@ -1,459 +0,0 @@
-/* GNU Objective C Runtime @synchronized implementation
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* This file implements objc_sync_enter() and objc_sync_exit(), the
- two functions required to support @synchronized().
-
- objc_sync_enter(object) needs to get a recursive lock associated
- with 'object', and lock it.
-
- objc_sync_exit(object) needs to get the recursive lock associated
- with 'object', and unlock it. */
-
-/* To avoid the overhead of continuously allocating and deallocating
- locks, we implement a pool of locks. When a lock is needed for an
- object, we get a lock from the pool and associate it with the
- object.
-
- The lock pool need to be protected by its own lock (the
- "protection" lock), which has to be locked then unlocked each time
- objc_sync_enter() and objc_sync_exit() are called. To reduce the
- contention on the protection lock, instead of a single pool with a
- single (global) protection lock we use a number of smaller pools,
- each with its own pool protection lock. To decide which lock pool
- to use for each object, we compute a hash from the object pointer.
-
- The implementation of each lock pool uses a linked list of all the
- locks in the pool (both unlocked, and locked); this works in the
- assumption that the number of locks concurrently required is very
- low. In practice, it seems that you rarely see more than a few
- locks ever concurrently required.
-
- A standard case is a thread acquiring a lock recursively, over and
- over again: for example when most methods of a class are protected
- by @synchronized(self) but they also call each other. We use
- thread-local storage to implement a cache and optimize this case.
- The cache stores locks that the thread successfully acquired,
- allowing objc_sync_enter() and objc_sync_exit() to locate a lock
- which is already held by the current thread without having to use
- any protection lock or synchronization mechanism. It can so detect
- recursive locks/unlocks, and transform them into no-ops that
- require no actual locking or synchronization mechanisms at all. */
-
-/* You can disable the thread-local cache (most likely to benchmark
- the code with and without it) by compiling with
- -DSYNC_CACHE_DISABLE, or commenting out the following line. */
-/* #define SYNC_CACHE_DISABLE */
-
-/* If thread-local storage is not available, automatically disable the
- cache. */
-#ifndef HAVE_TLS
-# define SYNC_CACHE_DISABLE
-#endif
-
-#include "objc-private/common.h"
-#include "objc/objc-sync.h" /* For objc_sync_enter(), objc_sync_exit() */
-#include "objc/runtime.h" /* For objc_malloc() */
-#include "objc/thr.h" /* For objc_mutex_loc() and similar */
-#include "objc-private/objc-sync.h" /* For __objc_sync_init() */
-
-/* We have 32 pools of locks, each of them protected by its own
- protection lock. It's tempting to increase this number to reduce
- contention; but in our tests it is high enough. */
-#define SYNC_NUMBER_OF_POOLS 32
-
-/* Given an object, it determines which pool contains the associated
- lock. */
-#define SYNC_OBJECT_HASH(OBJECT) ((((size_t)OBJECT >> 8) ^ (size_t)OBJECT) & (SYNC_NUMBER_OF_POOLS - 1))
-
-/* The locks protecting each pool. */
-static objc_mutex_t sync_pool_protection_locks[SYNC_NUMBER_OF_POOLS];
-
-/* The data structure (linked list) holding the locks. */
-typedef struct lock_node
-{
- /* Pointer to next entry on the list. NULL indicates end of list.
- You need to hold the appropriate sync_pool_protection_locks[N] to
- read or write this variable. */
- struct lock_node *next;
-
- /* The (recursive) lock. Allocated when the node is created, and
- always not-NULL, and unchangeable, after that. */
- objc_mutex_t lock;
-
- /* This is how many times the objc_mutex_lock() has been called on
- the lock (it is 0 when the lock is unused). Used to track when
- the lock is no longer associated with an object and can be reused
- for another object. It records "real" locks, potentially (but
- not necessarily) by multiple threads. You need to hold the
- appropriate sync_pool_protection_locks[N] to read or write this
- variable. */
- unsigned int usage_count;
-
- /* The object that the lock is associated with. This variable can
- only be written when holding the sync_pool_protection_locks[N]
- and when node->usage_count == 0, ie, the lock is not being used.
- You can read this variable either when you hold the
- sync_pool_protection_locks[N] or when you hold node->lock,
- because in that case you know that node->usage_count can't get to
- zero until you release the lock. It is valid to have usage_count
- == 0 and object != nil; in that case, the lock is not currently
- being used, but is still currently associated with the
- object. */
- id object;
-
- /* This is a counter reserved for use by the thread currently
- holding the lock. So, you need to hold node->lock to read or
- write this variable. It is normally 0, and if the cache is not
- being used, it is kept at 0 (even if recursive locks are being
- done; in that case, no difference is made between recursive and
- non-recursive locks: they all increase usage_count, and call
- objc_mutex_lock()). When the cache is being used, a thread may
- be able to find a lock that it already holds using the cache; in
- that case, to perform additional locks/unlocks it can
- increase/decrease the recursive_usage_count (which does not
- require any synchronization with other threads, since it's
- protected by the node->lock itself) instead of the usage_count
- (which requires locking the pool protection lock). And it can
- skip the call to objc_mutex_lock/unlock too. */
- unsigned int recursive_usage_count;
-} *lock_node_ptr;
-
-
-/* The pools of locks. Each of them is a linked list of lock_nodes.
- In the list we keep both unlocked and locked nodes. */
-static lock_node_ptr sync_pool_array[SYNC_NUMBER_OF_POOLS];
-
-#ifndef SYNC_CACHE_DISABLE
-/* We store a cache of locks acquired by each thread in thread-local
- storage. */
-static __thread lock_node_ptr *lock_cache = NULL;
-
-/* This is a conservative implementation that uses a static array of
- fixed size as cache. Because the cache is an array that we scan
- linearly, the bigger it is, the slower it gets. This does not
- matter much at small sizes (eg, the overhead of checking 8 cache
- slots instead of 4 is very small compared to the other overheads
- involved such as function calls and lock/unlock operations), but at
- large sizes it becomes important as obviously there is a size over
- which using the cache backfires: the lookup is so slow that the
- cache slows down the software instead of speeding it up. In
- practice, it seems that most threads use a small number of
- concurrent locks, so we have a conservative implementation with a
- fixed-size cache of 8 locks which gives a very predictable
- behaviour. If a thread locks lots of different locks, only the
- first 8 get the speed benefits of the cache, but the cache remains
- always small, fast and predictable.
-
- SYNC_CACHE_SIZE is the size of the lock cache for each thread. */
-#define SYNC_CACHE_SIZE 8
-#endif /* SYNC_CACHE_DISABLE */
-
-/* Called at startup by init.c. */
-void
-__objc_sync_init (void)
-{
- int i;
-
- for (i = 0; i < SYNC_NUMBER_OF_POOLS; i++)
- {
- lock_node_ptr new_node;
-
- /* Create a protection lock for each pool. */
- sync_pool_protection_locks[i] = objc_mutex_allocate ();
-
- /* Preallocate a lock per pool. */
- new_node = objc_malloc (sizeof (struct lock_node));
- new_node->lock = objc_mutex_allocate ();
- new_node->object = nil;
- new_node->usage_count = 0;
- new_node->recursive_usage_count = 0;
- new_node->next = NULL;
-
- sync_pool_array[i] = new_node;
- }
-}
-
-int
-objc_sync_enter (id object)
-{
-#ifndef SYNC_CACHE_DISABLE
- int free_cache_slot;
-#endif
- int hash;
- lock_node_ptr node;
- lock_node_ptr unused_node;
-
- if (object == nil)
- return OBJC_SYNC_SUCCESS;
-
-#ifndef SYNC_CACHE_DISABLE
- if (lock_cache == NULL)
- {
- /* Note that this calloc only happen only once per thread, the
- very first time a thread does a objc_sync_enter(). */
- lock_cache = objc_calloc (SYNC_CACHE_SIZE, sizeof (lock_node_ptr));
- }
-
- /* Check the cache to see if we have a record of having already
- locked the lock corresponding to this object. While doing so,
- keep track of the first free cache node in case we need it
- later. */
- node = NULL;
- free_cache_slot = -1;
-
- {
- int i;
- for (i = 0; i < SYNC_CACHE_SIZE; i++)
- {
- lock_node_ptr locked_node = lock_cache[i];
-
- if (locked_node == NULL)
- {
- if (free_cache_slot == -1)
- free_cache_slot = i;
- }
- else if (locked_node->object == object)
- {
- node = locked_node;
- break;
- }
- }
- }
-
- if (node != NULL)
- {
- /* We found the lock. Increase recursive_usage_count, which is
- protected by node->lock, which we already hold. */
- node->recursive_usage_count++;
-
- /* There is no need to actually lock anything, since we already
- hold the lock. Correspondingly, objc_sync_exit() will just
- decrease recursive_usage_count and do nothing to unlock. */
- return OBJC_SYNC_SUCCESS;
- }
-#endif /* SYNC_CACHE_DISABLE */
-
- /* The following is the standard lookup for the lock in the standard
- pool lock. It requires a pool protection lock. */
- hash = SYNC_OBJECT_HASH(object);
-
- /* Search for an existing lock for 'object'. While searching, make
- note of any unused lock if we find any. */
- unused_node = NULL;
-
- objc_mutex_lock (sync_pool_protection_locks[hash]);
-
- node = sync_pool_array[hash];
-
- while (node != NULL)
- {
- if (node->object == object)
- {
- /* We found the lock. */
- node->usage_count++;
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
-#ifndef SYNC_CACHE_DISABLE
- /* Put it in the cache. */
- if (free_cache_slot != -1)
- lock_cache[free_cache_slot] = node;
-#endif
-
- /* Lock it. */
- objc_mutex_lock (node->lock);
-
- return OBJC_SYNC_SUCCESS;
- }
-
- if (unused_node == NULL && node->usage_count == 0)
- {
- /* We found the first unused node. Record it. */
- unused_node = node;
- }
-
- node = node->next;
- }
-
- /* An existing lock for 'object' could not be found. */
- if (unused_node != NULL)
- {
- /* But we found a unused lock; use it. */
- unused_node->object = object;
- unused_node->usage_count = 1;
- unused_node->recursive_usage_count = 0;
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
-#ifndef SYNC_CACHE_DISABLE
- if (free_cache_slot != -1)
- lock_cache[free_cache_slot] = unused_node;
-#endif
-
- objc_mutex_lock (unused_node->lock);
-
- return OBJC_SYNC_SUCCESS;
- }
- else
- {
- /* There are no unused nodes; allocate a new node. */
- lock_node_ptr new_node;
-
- /* Create the node. */
- new_node = objc_malloc (sizeof (struct lock_node));
- new_node->lock = objc_mutex_allocate ();
- new_node->object = object;
- new_node->usage_count = 1;
- new_node->recursive_usage_count = 0;
-
- /* Attach it at the beginning of the pool. */
- new_node->next = sync_pool_array[hash];
- sync_pool_array[hash] = new_node;
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
-#ifndef SYNC_CACHE_DISABLE
- if (free_cache_slot != -1)
- lock_cache[free_cache_slot] = new_node;
-#endif
-
- objc_mutex_lock (new_node->lock);
-
- return OBJC_SYNC_SUCCESS;
- }
-}
-
-int
-objc_sync_exit (id object)
-{
- int hash;
- lock_node_ptr node;
-
- if (object == nil)
- return OBJC_SYNC_SUCCESS;
-
-#ifndef SYNC_CACHE_DISABLE
- if (lock_cache != NULL)
- {
- int i;
-
- /* Find the lock in the cache. */
- node = NULL;
- for (i = 0; i < SYNC_CACHE_SIZE; i++)
- {
- lock_node_ptr locked_node = lock_cache[i];
-
- if (locked_node != NULL && locked_node->object == object)
- {
- node = locked_node;
- break;
- }
- }
- /* Note that, if a node was found in the cache, the variable i
- now holds the index where it was found, which will be used to
- remove it from the cache. */
- if (node != NULL)
- {
- if (node->recursive_usage_count > 0)
- {
- node->recursive_usage_count--;
- return OBJC_SYNC_SUCCESS;
- }
- else
- {
- /* We need to do a real unlock. */
- hash = SYNC_OBJECT_HASH(object);
-
- /* TODO: If we had atomic increase/decrease operations
- with memory barriers, we could avoid the lock
- here! */
- objc_mutex_lock (sync_pool_protection_locks[hash]);
- node->usage_count--;
- /* Normally, we do not reset object to nil here. We'll
- leave the lock associated with that object, at zero
- usage count. This makes it slightly more efficient to
- provide a lock for that object if (as likely)
- requested again. If the object is deallocated, we
- don't care. It will never match a new lock that is
- requested, and the node will be reused at some point.
-
- But, if garbage collection is enabled, leaving a
- pointer to the object in memory might prevent the
- object from being released. In that case, we remove
- it (TODO: maybe we should avoid using the garbage
- collector at all ? Nothing is ever deallocated in
- this file). */
-#if OBJC_WITH_GC
- node->object = nil;
-#endif
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
- /* PS: Between objc_mutex_unlock
- (sync_pool_protection_locks[hash]) and
- objc_mutex_unlock (node->lock), the pool is unlocked
- so other threads may allocate this same lock to
- another object (!). This is not a problem, but it is
- curious. */
- objc_mutex_unlock (node->lock);
-
- /* Remove the node from the cache. */
- lock_cache[i] = NULL;
-
- return OBJC_SYNC_SUCCESS;
- }
- }
- }
-#endif
-
- /* The cache either wasn't there, or didn't work (eg, we overflowed
- it at some point and stopped recording new locks in the cache).
- Proceed with a full search of the lock pool. */
- hash = SYNC_OBJECT_HASH(object);
-
- objc_mutex_lock (sync_pool_protection_locks[hash]);
-
- /* Search for an existing lock for 'object'. */
- node = sync_pool_array[hash];
-
- while (node != NULL)
- {
- if (node->object == object)
- {
- /* We found the lock. */
- node->usage_count--;
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
- objc_mutex_unlock (node->lock);
-
- /* No need to remove the node from the cache, since it
- wasn't found in the cache when we looked for it! */
- return OBJC_SYNC_SUCCESS;
- }
-
- node = node->next;
- }
-
- objc_mutex_unlock (sync_pool_protection_locks[hash]);
-
- /* A lock for 'object' to unlock could not be found (!!). */
- return OBJC_SYNC_NOT_OWNING_THREAD_ERROR;
-}
diff --git a/libgcobol/objc/NXConstStr.h b/libgcobol/objc/NXConstStr.h
deleted file mode 100644
index 831897fb865a..000000000000
--- a/libgcobol/objc/NXConstStr.h
+++ /dev/null
@@ -1,51 +0,0 @@
-/* Interface for the NXConstantString class for Objective-C.
- Copyright (C) 1995-2022 Free Software Foundation, Inc.
- Contributed by Pieter J. Schoenmakers <tiggr@es.ele.tue.nl>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-
-#ifndef __nxconstantstring_INCLUDE_GNU
-#define __nxconstantstring_INCLUDE_GNU
-
-#include "Object.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-@interface NXConstantString: Object
-{
- char *c_string;
- unsigned int len;
-}
-
--(const char *) cString;
--(unsigned int) length;
-
-@end
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/libgcobol/objc/Object.h b/libgcobol/objc/Object.h
deleted file mode 100644
index bac4c0d7fcad..000000000000
--- a/libgcobol/objc/Object.h
+++ /dev/null
@@ -1,62 +0,0 @@
-/* Interface for the Object class for Objective-C.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-
-#ifndef __object_INCLUDE_GNU
-#define __object_INCLUDE_GNU
-
-#include "objc.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* The Object class is a very minimal root class included with the
- runtime. It is used as superclass for the two classes included
- with the runtime, Protocol and NXConstantString.
-
- Because Objective-C allows multiple root classes, you can define
- your own root class, different from Object.
-
- In particular, a Foundation library (such as GNUstep Base) is
- expected to provide its own root class (typically called NSObject),
- fully integrated with the library's own high-level features. It is
- expected that you should always use and interact with NSObject, and
- mostly ignore Object. */
-
-/* All classes are derived from Object. As such, this is the overhead
- tacked onto those objects. */
-@interface Object
-{
- Class isa; /* A pointer to the instance's class structure. */
-}
-- (Class)class;
-- (BOOL)isEqual: (id)anObject;
-@end
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/libgcobol/objc/Protocol.h b/libgcobol/objc/Protocol.h
deleted file mode 100644
index d52b8b1ee810..000000000000
--- a/libgcobol/objc/Protocol.h
+++ /dev/null
@@ -1,54 +0,0 @@
-/* Declare the class Protocol for Objective C programs.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-
-#ifndef __Protocol_INCLUDE_GNU
-#define __Protocol_INCLUDE_GNU
-
-#include "Object.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-@interface Protocol : Object
-{
-@private
- char *protocol_name;
- struct objc_protocol_list *protocol_list;
- struct objc_method_description_list *instance_methods, *class_methods;
-}
-@end
-
-/* The Protocol methods have been replaced by
- protocol_getName()
- protocol_conformsToProtocol()
- protocol_getMethodDescription()
-*/
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* not __Protocol_INCLUDE_GNU */
diff --git a/libgcobol/objc/README b/libgcobol/objc/README
deleted file mode 100644
index 69f17e581aeb..000000000000
--- a/libgcobol/objc/README
+++ /dev/null
@@ -1,2 +0,0 @@
-This directory contains the public headers that are installed when
-libobjc is installed.
diff --git a/libgcobol/objc/message.h b/libgcobol/objc/message.h
deleted file mode 100644
index 7e5f355da560..000000000000
--- a/libgcobol/objc/message.h
+++ /dev/null
@@ -1,119 +0,0 @@
-/* GNU Objective C Runtime messaging declarations
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_message_INCLUDE_GNU
-#define __objc_message_INCLUDE_GNU
-
-#include "objc.h"
-#include "objc-decls.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* This file includes declarations of the messaging functions and
- types. */
-
-/* Compatibility note: the messaging function is one area where the
- GNU runtime and the Apple/NeXT runtime differ significantly. If
- you can, it is recommended that you use higher-level facilities
- (provided by a Foundation library such as GNUstep Base) to perform
- forwarding or other advanced messaging tricks. */
-
-/* This function returns the IMP (C function implementing a method) to
- use to invoke the method with selector 'op' of receiver 'receiver'.
-
- This is the function used by the compiler when compiling method
- invocations with the GNU runtime. For example, the method call
-
- result = [receiver method];
-
- is compiled by the compiler (with the GNU runtime) into the
- equivalent of:
-
- {
- IMP function = objc_msg_lookup (receiver, @selector (method));
- result = function (receiver, @selector (method));
- }
-
- so, a call to objc_msg_lookup() determines the IMP (the C function
- implementing the method) to call. Then, the function is called.
- If the method takes or returns different arguments, the compiler
- will cast 'function' to the right type before invoking it, making
- sure arguments and return value are handled correctly.
-
- objc_msg_lookup() must always return a valid function that can be
- called with the required method signature (otherwise the
- compiler-generated code shown above could segfault). If 'receiver'
- is NULL, objc_msg_lookup() returns a C function that does nothing,
- ignores all its arguments, and returns NULL (see nil_method.c). If
- 'receiver' does not respond to the selector 'op', objc_msg_lookup()
- will try to call +resolveClassMethod: or resolveInstanceMethod: as
- appropriate, and if they return YES, it will try the lookup again
- (+resolveClassMethod: and +resolveInstanceMethod: can thus install
- dynamically methods as they are requested). If
- +resolveClassMethod: or +resolveInstanceMethod: are either not
- available, or return NO, or return YES but 'receiver' still doesn't
- implement the 'selector' after calling them, the runtime returns a
- generic "forwarding" function that can be called with the required
- method signature and which can process the method invocation
- according to the forwarding API. There are two runtime hooks that
- allow Foundation libraries (such as GNUstep-Base) to return their
- own forwarding function in preference to the runtime ones. When
- that happens, the Foundation library effectively takes complete
- control of the forwarding process; any method invocation where the
- selector is not implemented by the receiver will end up calling a
- forwarding function chosen by the Foundation library. */
-objc_EXPORT IMP objc_msg_lookup (id receiver, SEL op);
-
-/* Structure used when a message is send to a class's super class.
- The compiler generates one of these structures and passes it to
- objc_msg_lookup_super() when a [super method] call is compiled. */
-
-/* Modern API. */
-struct objc_super
-{
- id self; /* The receiver of the message. */
- Class super_class; /* The superclass of the receiver. */
-};
-
-/* This is used by the compiler instead of objc_msg_lookup () when
- compiling a call to 'super', such as [super method]. This requires
- sending a message to super->self, but looking up the method as if
- super->self was in class super->super_class. */
-objc_EXPORT IMP objc_msg_lookup_super (struct objc_super *super, SEL sel);
-
-/* Hooks for method forwarding. They make it easy to substitute the
- built-in forwarding with one based on a library, such as ffi, that
- implement closures, thereby avoiding gcc's __builtin_apply
- problems. __objc_msg_forward2's result will be preferred over that
- of __objc_msg_forward if both are set and return non-NULL. */
-objc_EXPORT IMP (*__objc_msg_forward)(SEL);
-objc_EXPORT IMP (*__objc_msg_forward2)(id, SEL);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* not __objc_message_INCLUDE_GNU */
diff --git a/libgcobol/objc/objc-decls.h b/libgcobol/objc/objc-decls.h
deleted file mode 100644
index 826d0a2cbdcd..000000000000
--- a/libgcobol/objc/objc-decls.h
+++ /dev/null
@@ -1,46 +0,0 @@
-/* GNU Objective-C Extern helpers for Win32.
- Copyright (C) 2004-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-
-#ifndef __objc_decls_INCLUDE_GNU
-#define __objc_decls_INCLUDE_GNU
-
-#if defined (_WIN32) || defined (__WIN32__) || defined (WIN32)
-
-# ifdef DLL_EXPORT /* defined by libtool (if required) */
-# define objc_EXPORT extern
-# define objc_DECLARE
-# else
-# define objc_EXPORT extern __declspec(dllimport)
-# define objc_DECLARE extern __declspec(dllimport)
-# endif
-
-#else
-
-# define objc_EXPORT extern
-# define objc_DECLARE
-
-#endif
-
-#endif /* __objc_decls_INCLUDE_GNU */
diff --git a/libgcobol/objc/objc-exception.h b/libgcobol/objc/objc-exception.h
deleted file mode 100644
index dd1735445920..000000000000
--- a/libgcobol/objc/objc-exception.h
+++ /dev/null
@@ -1,109 +0,0 @@
-/* GNU Objective C Runtime native exceptions
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_exception_INCLUDE_GNU
-#define __objc_exception_INCLUDE_GNU
-
-#include "objc.h"
-#include "objc-decls.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* 'objc_exception_throw' throws the exception 'exception', which is
- an exception object.
-
- Calls to 'objc_exception_throw' are automatically generated by the
- compiler: an Objective-C "@throw exception;" statement gets
- compiled into the equivalent of "objc_exception_throw
- (exception);".
-
- 'objc_exception_throw' searches for a @catch() that can catch the
- exception. By default, @catch (MyClass object) will catch all
- exception objects that are of class MyClass or of a subclass of
- MyClass; if the exception object is 'nil', then the exception can
- only be caught with a catch-all exception handler where no
- exception class is specified (such as @catch(id object)). This
- behaviour can be customized by setting an 'objc_exception_matcher'
- function (using objc_set_exception_matcher(), see below); if one is
- set, it is used instead of the default one.
-
- If the exception is uncaught (there is no @catch() to catch it),
- the program aborts. It is possible to customize this behaviour by
- setting an 'objc_uncaught_exception_handler' function (using
- objc_set_uncaught_exception_handler(), see below); if one is set,
- it is executed before abort() is called. An uncaught exception
- handler is expected to never return. */
-objc_EXPORT void objc_exception_throw (id exception);
-
-/* Compatibility note: the Apple/NeXT runtime seems to also have
- objc_exception_rethrow(), objc_begin_catch() and objc_end_catch().
- Currently the GNU runtime does not use them. */
-
-/* The following functions allow customizing to a certain extent the
- exception handling. They are not thread safe and should be called
- during the program initialization before threads are started. They
- are mostly reserved for "Foundation" libraries; in the case of
- GNUstep, GNUstep Base may be using these functions to improve the
- standard exception handling. You probably shouldn't use these
- functions unless you are writing your own Foundation library. */
-
-/* Compatibility note: objc_set_exception_preprocessor() (available on
- the Apple/NeXT runtime) is not available on the GNU runtime. */
-
-/* An 'objc_exception_matcher' function is used to match an exception
- to a @catch clause. 'catch_class' is the class of objects caught
- by the @catch clause (for example, in "@catch (Object *o)", the
- catch_class is Object). It should return 1 if the exception should
- be caught by a @catch with a catch_class argument, and 0 if
- not. */
-typedef int (*objc_exception_matcher)(Class catch_class, id exception);
-
-/* Sets a new exception matcher function, and returns the previous
- exception matcher function. This function is not safe to call in a
- multi-threaded environment because other threads may be trying to
- invoke the exception matcher while you change it! */
-objc_EXPORT objc_exception_matcher
-objc_setExceptionMatcher (objc_exception_matcher new_matcher);
-
-
-/* An 'objc_uncaught_exception_handler' function is a function that
- handles uncaught exceptions. It should never return. */
-typedef void (*objc_uncaught_exception_handler)(id exception);
-
-/* Sets a new uncaught exception handler function, and returns the
- previous exception handler function. This function is not safe to
- call in a multi-threaded environment because other threads may be
- trying to invoke the uncaught exception handler while you change
- it. */
-objc_EXPORT objc_uncaught_exception_handler
-objc_setUncaughtExceptionHandler (objc_uncaught_exception_handler new_handler);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* not __objc_exception_INCLUDE_GNU */
diff --git a/libgcobol/objc/objc-sync.h b/libgcobol/objc/objc-sync.h
deleted file mode 100644
index c2db4c718883..000000000000
--- a/libgcobol/objc/objc-sync.h
+++ /dev/null
@@ -1,69 +0,0 @@
-/* GNU Objective C Runtime @synchronized implementation
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_sync_INCLUDE_GNU
-#define __objc_sync_INCLUDE_GNU
-
-#include "objc.h"
-#include "objc-decls.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* These functions are automatically called by @synchronized(). */
-
-/* 'objc_sync_enter' is automatically called when entering a
- @synchronized() block. It locks the recursive lock associated with
- 'object'. If 'object' is nil, it does nothing. It returns
- OBJC_SYNC_SUCCESS on success; see the enumeration below for error
- values.
-
- Note that you should not rely on the behaviour when 'object' is nil
- because it could change. */
-objc_EXPORT int objc_sync_enter (id object);
-
-/* 'objc_sync_exit' is automatically called when exiting from a
- @synchronized() block. It unlocks the recursive lock associated
- with 'object'. If 'object' is nil, it does nothing. It returns
- OBJC_SYNC_SUCCESS on success; see the enumeration below for error
- values. */
-objc_EXPORT int objc_sync_exit (id object);
-
-/* All the possible return values for objc_sync_enter() and
- objc_sync_exit().
- */
-enum {
- OBJC_SYNC_SUCCESS = 0,
- OBJC_SYNC_NOT_OWNING_THREAD_ERROR = -1,
- OBJC_SYNC_TIMED_OUT = -2,
- OBJC_SYNC_NOT_INITIALIZED = -3
-};
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* not __objc_sync_INCLUDE_GNU */
diff --git a/libgcobol/objc/objc.h b/libgcobol/objc/objc.h
deleted file mode 100644
index aea7949de07a..000000000000
--- a/libgcobol/objc/objc.h
+++ /dev/null
@@ -1,151 +0,0 @@
-/* Basic data types for Objective C.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_INCLUDE_GNU
-#define __objc_INCLUDE_GNU
-
-/* This file contains the definition of the basic types used by the
- Objective-C language. It needs to be included to do almost
- anything with Objective-C. */
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-#include <stddef.h>
-
-/* The current version of the GNU Objective-C Runtime library in
- compressed ISO date format. This should be updated any time a new
- version is released with changes to the public API (there is no
- need to update it if there were no API changes since the previous
- release). This macro is only defined starting with the GNU
- Objective-C Runtime shipped with GCC 4.6.0. If it is not defined,
- it is either an older version of the runtime, or another runtime. */
-#define __GNU_LIBOBJC__ 20110608
-
-/* Definition of the boolean type.
-
- Compatibility note: the Apple/NeXT runtime defines a BOOL as a
- 'signed char'. The GNU runtime uses an 'unsigned char'.
-
- Important: this could change and we could switch to 'typedef bool
- BOOL' in the future. Do not depend on the type of BOOL. */
-#undef BOOL
-typedef unsigned char BOOL;
-
-#define YES (BOOL)1
-#define NO (BOOL)0
-
-/* The basic Objective-C types (SEL, Class, id) are defined as pointer
- to opaque structures. The details of the structures are private to
- the runtime and may potentially change from one version to the
- other. */
-
-/* A SEL (selector) represents an abstract method (in the
- object-oriented sense) and includes all the details of how to
- invoke the method (which means its name, arguments and return
- types) but provides no implementation of its own. You can check
- whether a class implements a selector or not, and if you have a
- selector and know that the class implements it, you can use it to
- call the method for an object in the class. */
-typedef const struct objc_selector *SEL;
-
-/* A Class is a class (in the object-oriented sense). In Objective-C
- there is the complication that each Class is an object itself, and
- so belongs to a class too. This class that a class belongs to is
- called its 'meta class'. */
-typedef struct objc_class *Class;
-
-/* An 'id' is an object of an unknown class. The way the object data
- is stored inside the object is private and what you see here is
- only the beginning of the actual struct. The first field is always
- a pointer to the Class that the object belongs to. */
-typedef struct objc_object
-{
- /* 'class_pointer' is the Class that the object belongs to. In case
- of a Class object, this pointer points to the meta class.
-
- Compatibility Note: The Apple/NeXT runtime calls this field
- 'isa'. To access this field, use object_getClass() from
- runtime.h, which is an inline function so does not add any
- overhead and is also portable to other runtimes. */
- Class class_pointer;
-} *id;
-
-/* 'IMP' is a C function that implements a method. When retrieving
- the implementation of a method from the runtime, this is the type
- of the pointer returned. The idea of the definition of IMP is to
- represent a 'pointer to a general function taking an id, a SEL,
- followed by other unspecified arguments'. You must always cast an
- IMP to a pointer to a function taking the appropriate, specific
- types for that function, before calling it - to make sure the
- appropriate arguments are passed to it. The code generated by the
- compiler to perform method calls automatically does this cast
- inside method calls. */
-typedef id (*IMP)(id, SEL, ...);
-
-/* 'nil' is the null object. Messages to nil do nothing and always
- return 0. */
-#define nil (id)0
-
-/* 'Nil' is the null class. Since classes are objects too, this is
- actually the same object as 'nil' (and behaves in the same way),
- but it has a type of Class, so it is good to use it instead of
- 'nil' if you are comparing a Class object to nil as it enables the
- compiler to do some type-checking. */
-#define Nil (Class)0
-
-/* TODO: Move the 'Protocol' declaration into objc/runtime.h. A
- Protocol is simply an object, not a basic Objective-C type. The
- Apple runtime defines Protocol in objc/runtime.h too, so it's good
- to move it there for API compatibility. */
-
-/* A 'Protocol' is a formally defined list of selectors (normally
- created using the @protocol Objective-C syntax). It is mostly used
- at compile-time to check that classes implement all the methods
- that they are supposed to. Protocols are also available in the
- runtime system as Protocol objects. */
-#ifndef __OBJC__
- /* Once we stop including the deprecated struct_objc_protocol.h
- there is no reason to even define a 'struct objc_protocol'. As
- all the structure details will be hidden, a Protocol basically is
- simply an object (as it should be). */
- typedef struct objc_object Protocol;
-#else /* __OBJC__ */
- @class Protocol;
-#endif
-
-/* Compatibility note: the Apple/NeXT runtime defines sel_getName(),
- sel_registerName(), object_getClassName(), object_getIndexedIvars()
- in this file while the GNU runtime defines them in runtime.h.
-
- The reason the GNU runtime does not define them here is that they
- are not basic Objective-C types (defined in this file), but are
- part of the runtime API (defined in runtime.h). */
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* not __objc_INCLUDE_GNU */
diff --git a/libgcobol/objc/runtime.h b/libgcobol/objc/runtime.h
deleted file mode 100644
index 5a9cb945f426..000000000000
--- a/libgcobol/objc/runtime.h
+++ /dev/null
@@ -1,1143 +0,0 @@
-/* GNU Objective-C Runtime API - Modern API
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero <nicola.pero@meta-innovation.com>
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any
-later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __objc_runtime_INCLUDE_GNU
-#define __objc_runtime_INCLUDE_GNU
-
-/*
- This file declares the "modern" GNU Objective-C Runtime API.
-
- This API replaced the "traditional" GNU Objective-C Runtime API
- (which used to be declared in objc/objc-api.h) which is the one
- supported by older versions of the GNU Objective-C Runtime. The
- "modern" API is very similar to the API used by the modern
- Apple/NeXT runtime.
-*/
-#include "objc.h"
-#include "objc-decls.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif /* __cplusplus */
-
-/* An 'Ivar' represents an instance variable. It holds information
- about the name, type and offset of the instance variable. */
-typedef struct objc_ivar *Ivar;
-
-/* A 'Property' represents a property. It holds information about the
- name of the property, and its attributes.
-
- Compatibility Note: the Apple/NeXT runtime defines this as
- objc_property_t, so we define it that way as well, but obviously
- Property is the right name. */
-typedef struct objc_property *Property;
-typedef struct objc_property *objc_property_t;
-
-/* A 'Method' represents a method. It holds information about the
- name, types and the IMP of the method. */
-typedef struct objc_method *Method;
-
-/* A 'Category' represents a category. It holds information about the
- name of the category, the class it belongs to, and the methods,
- protocols and such like provided by the category. */
-typedef struct objc_category *Category;
-
-/* 'Protocol' is defined in objc/objc.h (which is included by this
- file). */
-
-/* Method descriptor returned by introspective Object methods. At the
- moment, this is really just the first part of the more complete
- objc_method structure used internally by the runtime. (PS: In the
- GNU Objective-C Runtime, selectors already include a type, so an
- objc_method_description does not add much to a SEL. But in other
- runtimes, that is not the case, which is why
- objc_method_description exists). */
-struct objc_method_description
-{
- SEL name; /* Selector (name and signature) */
- char *types; /* Type encoding */
-};
-
-/* The following are used in encode strings to describe the type of
- Ivars and Methods. */
-#define _C_ID '@'
-#define _C_CLASS '#'
-#define _C_SEL ':'
-#define _C_CHR 'c'
-#define _C_UCHR 'C'
-#define _C_SHT 's'
-#define _C_USHT 'S'
-#define _C_INT 'i'
-#define _C_UINT 'I'
-#define _C_LNG 'l'
-#define _C_ULNG 'L'
-#define _C_LNG_LNG 'q'
-#define _C_ULNG_LNG 'Q'
-#define _C_FLT 'f'
-#define _C_DBL 'd'
-#define _C_LNG_DBL 'D'
-#define _C_BFLD 'b'
-#define _C_BOOL 'B'
-#define _C_VOID 'v'
-#define _C_UNDEF '?'
-#define _C_PTR '^'
-#define _C_CHARPTR '*'
-#define _C_ARY_B '['
-#define _C_ARY_E ']'
-#define _C_UNION_B '('
-#define _C_UNION_E ')'
-#define _C_STRUCT_B '{'
-#define _C_STRUCT_E '}'
-#define _C_VECTOR '!'
-#define _C_COMPLEX 'j'
-
-/* _C_ATOM is never generated by the compiler. You can treat it as
- equivalent to "*". */
-#define _C_ATOM '%'
-
-/* The following are used in encode strings to describe some
- qualifiers of method and ivar types. */
-#define _C_CONST 'r'
-#define _C_IN 'n'
-#define _C_INOUT 'N'
-#define _C_OUT 'o'
-#define _C_BYCOPY 'O'
-#define _C_BYREF 'R'
-#define _C_ONEWAY 'V'
-#define _C_GCINVISIBLE '|'
-
-/* The same when used as flags. */
-#define _F_CONST 0x01
-#define _F_IN 0x01
-#define _F_OUT 0x02
-#define _F_INOUT 0x03
-#define _F_BYCOPY 0x04
-#define _F_BYREF 0x08
-#define _F_ONEWAY 0x10
-#define _F_GCINVISIBLE 0x20
-
-
-/** Implementation: the following functions are defined inline. */
-
-/* Return the class of 'object', or Nil if the object is nil. If
- 'object' is a class, the meta class is returned; if 'object' is a
- meta class, the root meta class is returned (note that this is
- different from the traditional GNU Objective-C Runtime API function
- object_get_class(), which for a meta class would return the meta
- class itself). This function is inline, so it is really fast and
- should be used instead of accessing object->class_pointer
- directly. */
-static inline Class
-object_getClass (id object)
-{
- if (object != nil)
- return object->class_pointer;
- else
- return Nil;
-}
-
-
-/** Implementation: the following functions are in selector.c. */
-
-/* Return the name of a given selector. If 'selector' is NULL, return
- "<null selector>". */
-objc_EXPORT const char *sel_getName (SEL selector);
-
-/* Return the type of a given selector. Return NULL if selector is
- NULL.
-
- Compatibility Note: the Apple/NeXT runtime has untyped selectors,
- so it does not have this function, which is specific to the GNU
- Runtime. */
-objc_EXPORT const char *sel_getTypeEncoding (SEL selector);
-
-/* This is the same as sel_registerName (). Please use
- sel_registerName () instead. */
-objc_EXPORT SEL sel_getUid (const char *name);
-
-/* Register a selector with a given name (but unspecified types). If
- you know the types, it is better to call sel_registerTypedName().
- If a selector with this name and no types already exists, it is
- returned. Note that this function should really be called
- 'objc_registerSelector'. Return NULL if 'name' is NULL. */
-objc_EXPORT SEL sel_registerName (const char *name);
-
-/* Register a selector with a given name and types. If a selector
- with this name and types already exists, it is returned. Note that
- this function should really be called 'objc_registerTypedSelector',
- and it's called 'sel_registerTypedName' only for consistency with
- 'sel_registerName'. Return NULL if 'name' is NULL.
-
- Compatibility Note: the Apple/NeXT runtime has untyped selectors,
- so it does not have this function, which is specific to the GNU
- Runtime. */
-objc_EXPORT SEL sel_registerTypedName (const char *name, const char *type);
-
-/* Return YES if first_selector is the same as second_selector, and NO
- if not. */
-objc_EXPORT BOOL sel_isEqual (SEL first_selector, SEL second_selector);
-
-/* Return all the selectors with the supplied name. In the GNU
- runtime, selectors are typed and there may be multiple selectors
- with the same name but a different type. The return value of the
- function is a pointer to an area, allocated with malloc(), that
- contains all the selectors with the supplier name known to the
- runtime. The list is terminated by NULL. Optionally, if you pass
- a non-NULL 'numberOfReturnedSelectors' pointer, the unsigned int
- that it points to will be filled with the number of selectors
- returned.
-
- Compatibility Note: the Apple/NeXT runtime has untyped selectors,
- so it does not have this function, which is specific to the GNU
- Runtime. */
-objc_EXPORT SEL * sel_copyTypedSelectorList (const char *name,
- unsigned int *numberOfReturnedSelectors);
-
-/* Return a selector with name 'name' and a non-zero type encoding, if
- there is a single selector with a type, and with that name,
- registered with the runtime. If there is no such selector, or if
- there are multiple selectors with the same name but conflicting
- types, NULL is returned. Return NULL if 'name' is NULL.
-
- This is useful if you have the name of the selector, and would
- really like to get a selector for it that includes the type
- encoding. Unfortunately, if the program contains multiple selector
- with the same name but different types, sel_getTypedSelector cannot
- possibly know which one you need, and so will return NULL.
-
- Compatibility Note: the Apple/NeXT runtime has untyped selectors,
- so it does not have this function, which is specific to the GNU
- Runtime. */
-objc_EXPORT SEL sel_getTypedSelector (const char *name);
-
-
-/** Implementation: the following functions are in objects.c. */
-
-/* Create an instance of class 'class_', adding extraBytes to the size
- of the returned object. This method allocates the appropriate
- amount of memory for the instance, initializes it to zero, then
- calls all the C++ constructors on appropriate C++ instance
- variables of the instance (if any) (TODO: The C++ constructors bit
- is not implemented yet). */
-objc_EXPORT id class_createInstance (Class class_, size_t extraBytes);
-
-/* Copy an object and return the copy. extraBytes should be identical
- to the extraBytes parameter that was passed when creating the
- original object. */
-objc_EXPORT id object_copy (id object, size_t extraBytes);
-
-/* Dispose of an object. This method calls the appropriate C++
- destructors on appropriate C++ instance variables of the instance
- (if any) (TODO: This is not implemented yet), then frees the memory
- for the instance. */
-objc_EXPORT id object_dispose (id object);
-
-/* Return the name of the class of 'object'. If 'object' is 'nil',
- returns "Nil". */
-objc_EXPORT const char * object_getClassName (id object);
-
-/* Change the class of object to be class_. Return the previous class
- of object. This is currently not really thread-safe. */
-objc_EXPORT Class object_setClass (id object, Class class_);
-
-
-/** Implementation: the following functions are in ivars.c. */
-
-/* Return an instance variable given the class and the instance
- variable name. This is an expensive function to call, so try to
- reuse the returned Ivar if you can. */
-objc_EXPORT Ivar class_getInstanceVariable (Class class_, const char *name);
-
-/* Return a class variable given the class and the class variable
- name. This is an expensive function to call, so try to reuse the
- returned Ivar if you can.
-
- This function always returns NULL since class variables are
- currently unavailable in Objective-C. */
-objc_EXPORT Ivar class_getClassVariable (Class class_, const char *name);
-
-/* If the object was created in class_createInstance() with some
- extraBytes, returns a pointer to them. If it was not, then the
- returned pointer may make no sense. */
-objc_EXPORT void * object_getIndexedIvars (id object);
-
-/* Get the value of an instance variable of type 'id'. The function
- returns the instance variable. To get the value of the instance
- variable, you should pass as 'returnValue' a pointer to an 'id';
- the value will be copied there. Note that 'returnValue' is really
- a 'void *', not a 'void **'. This function really works only with
- instance variables of type 'id'; for other types of instance
- variables, access directly the data at (char *)object +
- ivar_getOffset (ivar). */
-objc_EXPORT Ivar object_getInstanceVariable (id object, const char *name, void **returnValue);
-
-/* Set the value of an instance variable. The value to set is passed
- in 'newValue' (which really is an 'id', not a 'void *'). The
- function returns the instance variable. This function really works
- only with instance variables of type 'id'; for other types of
- instance variables, access directly the data at (char *)object +
- ivar_getOffset (ivar). */
-objc_EXPORT Ivar object_setInstanceVariable (id object, const char *name, void *newValue);
-
-/* Get the value of an instance variable of type 'id' of the object
- 'object'. This is faster than object_getInstanceVariable if you
- already have the instance variable because it avoids the expensive
- call to class_getInstanceVariable that is done by
- object_getInstanceVariable. */
-objc_EXPORT id object_getIvar (id object, Ivar variable);
-
-/* Set the value of an instance variable of type 'id' of the object
- 'object'. This is faster than object_setInstanceVariable if you
- already have the instance variable because it avoids the expensive
- call to class_getInstanceVariable that is done by
- object_setInstanceVariable. */
-objc_EXPORT void object_setIvar (id object, Ivar variable, id value);
-
-/* Return the name of the instance variable. Return NULL if
- 'variable' is NULL. */
-objc_EXPORT const char * ivar_getName (Ivar variable);
-
-/* Return the offset of the instance variable from the start of the
- object data. Return 0 if 'variable' is NULL. */
-objc_EXPORT ptrdiff_t ivar_getOffset (Ivar variable);
-
-/* Return the type encoding of the variable. Return NULL if
- 'variable' is NULL. */
-objc_EXPORT const char * ivar_getTypeEncoding (Ivar variable);
-
-/* Return all the instance variables of the class. The return value
- of the function is a pointer to an area, allocated with malloc(),
- that contains all the instance variables of the class. It does not
- include instance variables of superclasses. The list is terminated
- by NULL. Optionally, if you pass a non-NULL
- 'numberOfReturnedIvars' pointer, the unsigned int that it points to
- will be filled with the number of instance variables returned.
- Return NULL for classes still in construction (ie, allocated using
- objc_allocatedClassPair() but not yet registered with the runtime
- using objc_registerClassPair()). */
-objc_EXPORT Ivar * class_copyIvarList (Class class_, unsigned int *numberOfReturnedIvars);
-
-/* Add an instance variable with name 'ivar_name' to class 'class_',
- where 'class_' is a class in construction that has been created
- using objc_allocateClassPair() and has not been registered with the
- runtime using objc_registerClassPair() yet. You cannot add
- instance variables to classes already registered with the runtime.
- 'size' is the size of the instance variable, 'log_2_of_alignment'
- the alignment as a power of 2 (so 0 means alignment to a 1 byte
- boundary, 1 means alignment to a 2 byte boundary, 2 means alignment
- to a 4 byte boundary, etc), and 'type' the type encoding of the
- variable type. You can use sizeof(), log2(__alignof__()) and
- @encode() to determine the right 'size', 'alignment' and 'type' for
- your instance variable. For example, to add an instance variable
- name "my_variable" and of type 'id', you can use:
-
- class_addIvar (class, "my_variable", sizeof (id), log2 ( __alignof__ (id)),
- @encode (id));
-
- Return YES if the variable was added, and NO if not. In
- particular, return NO if 'class_' is Nil, or a meta-class or a
- class not in construction. Return Nil also if 'ivar_name' or
- 'type' is NULL, or 'size' is 0.
- */
-objc_EXPORT BOOL class_addIvar (Class class_, const char * ivar_name, size_t size,
- unsigned char log_2_of_alignment, const char *type);
-
-/* Return the name of the property. Return NULL if 'property' is
- NULL. */
-objc_EXPORT const char * property_getName (Property property);
-
-/* Return the attributes of the property as a string. Return NULL if
- 'property' is NULL. */
-objc_EXPORT const char * property_getAttributes (Property property);
-
-/* Return the property with name 'propertyName' of the class 'class_'.
- This function returns NULL if the required property cannot be
- found. Return NULL if 'class_' or 'propertyName' is NULL.
-
- Note that the traditional ABI does not store the list of properties
- of a class in a compiled module, so the traditional ABI will always
- return NULL. */
-objc_EXPORT Property class_getProperty (Class class_, const char *propertyName);
-
-/* Return all the properties of the class. The return value
- of the function is a pointer to an area, allocated with malloc(),
- that contains all the properties of the class. It does not
- include properties of superclasses. The list is terminated
- by NULL. Optionally, if you pass a non-NULL
- 'numberOfReturnedIvars' pointer, the unsigned int that it points to
- will be filled with the number of properties returned.
-
- Note that the traditional ABI does not store the list of properties
- of a class in a compiled module, so the traditional ABI will always
- return an empty list. */
-objc_EXPORT Property * class_copyPropertyList
-(Class class_, unsigned int *numberOfReturnedProperties);
-
-/* Return the ivar layout for class 'class_'.
-
- At the moment this function always returns NULL. */
-objc_EXPORT const char * class_getIvarLayout (Class class_);
-
-/* Return the weak ivar layout for class 'class_'.
-
- At the moment this function always returns NULL. */
-objc_EXPORT const char * class_getWeakIvarLayout (Class class_);
-
-/* Set the ivar layout for class 'class_'.
-
- At the moment, this function does nothing. */
-objc_EXPORT void class_setIvarLayout (Class class_, const char *layout);
-
-/* Set the weak ivar layout for class 'class_'.
-
- At the moment, this function does nothing. With the GNU runtime,
- you should use class_ivar_set_gcinvisible () to hide variables from
- the Garbage Collector. */
-objc_EXPORT void class_setWeakIvarLayout (Class class_, const char *layout);
-
-
-/** Implementation: the following functions are in class.c. */
-
-/* Compatibility Note: The Apple/NeXT runtime does not have
- objc_get_unknown_class_handler and
- objc_setGetUnknownClassHandler(). They provide functionality that
- the traditional GNU Objective-C Runtime API used to provide via the
- _objc_lookup_class hook. */
-
-/* An 'objc_get_unknown_class_handler' function is used by
- objc_getClass() to get a class that is currently unknown to the
- compiler. You could use it for example to have the class loaded by
- dynamically loading a library. 'class_name' is the name of the
- class. The function should return the Class object if it manages to
- load the class, and Nil if not. */
-typedef Class (*objc_get_unknown_class_handler)(const char *class_name);
-
-/* Sets a new handler function for getting unknown classes (to be used
- by objc_getClass () and related), and returns the previous one.
- This function is not safe to call in a multi-threaded environment
- because other threads may be trying to use the get unknown class
- handler while you change it! */
-objc_EXPORT
-objc_get_unknown_class_handler
-objc_setGetUnknownClassHandler (objc_get_unknown_class_handler new_handler);
-
-/* Return the class with name 'name', if it is already registered with
- the runtime. If it is not registered, and
- objc_setGetUnknownClassHandler() has been called to set a handler
- for unknown classes, the handler is called to give it a chance to
- load the class in some other way. If the class is not known to the
- runtime and the handler is not set or returns Nil, objc_getClass()
- returns Nil. */
-objc_EXPORT Class objc_getClass (const char *name);
-
-/* Return the class with name 'name', if it is already registered with
- the runtime. Return Nil if not. This function does not call the
- objc_get_unknown_class_handler function if the class is not
- found. */
-objc_EXPORT Class objc_lookUpClass (const char *name);
-
-/* Return the meta class associated to the class with name 'name', if
- it is already registered with the runtime. First, it finds the
- class using objc_getClass(). Then, it returns the associated meta
- class. If the class could not be found using objc_getClass(),
- returns Nil. */
-objc_EXPORT Class objc_getMetaClass (const char *name);
-
-/* This is identical to objc_getClass(), but if the class is not found,
- it aborts the process instead of returning Nil. */
-objc_EXPORT Class objc_getRequiredClass (const char *name);
-
-/* If 'returnValue' is NULL, 'objc_getClassList' returns the number of
- classes currently registered with the runtime. If 'returnValue' is
- not NULL, it should be a (Class *) pointer to an area of memory
- which can contain up to 'maxNumberOfClassesToReturn' Class records.
- 'objc_getClassList' will fill the area pointed to by 'returnValue'
- with all the Classes registered with the runtime (or up to
- maxNumberOfClassesToReturn if there are more than
- maxNumberOfClassesToReturn). The function return value is the
- number of classes actually returned in 'returnValue'. */
-objc_EXPORT int objc_getClassList (Class *returnValue, int maxNumberOfClassesToReturn);
-
-/* Compatibility Note: The Apple/NeXT runtime also has
-
- Class objc_getFutureClass (const char *name);
- void objc_setFutureClass (Class class_, const char *name);
-
- the documentation is unclear on what they are supposed to do, and
- the GNU Objective-C Runtime currently does not provide them. */
-
-/* Return the name of the class 'class_', or the string "nil" if the
- class_ is Nil. */
-objc_EXPORT const char * class_getName (Class class_);
-
-/* Return YES if 'class_' is a meta class, and NO if not. If 'class_'
- is Nil, return NO. */
-objc_EXPORT BOOL class_isMetaClass (Class class_);
-
-/* Return the superclass of 'class_'. If 'class_' is Nil, or it is a
- root class, return Nil. This function also works if 'class_' is a
- class being constructed, that is, a class returned by
- objc_allocateClassPair() but before it has been registered with the
- runtime using objc_registerClassPair(). */
-objc_EXPORT Class class_getSuperclass (Class class_);
-
-/* Return the 'version' number of the class, which is an integer that
- can be used to track changes in the class API, methods and
- variables. If class_ is Nil, return 0. If class_ is not Nil, the
- version is 0 unless class_setVersion() has been called to set a
- different one.
-
- Please note that internally the version is a long, but the API only
- allows you to set and retrieve int values. */
-objc_EXPORT int class_getVersion (Class class_);
-
-/* Set the 'version' number of the class, which is an integer that can
- be used to track changes in the class API, methods and variables.
- If 'class_' is Nil, does nothing.
-
- This is typically used internally by "Foundation" libraries such as
- GNUstep Base to support serialization / deserialization of objects
- that work across changes in the classes. If you are using such a
- library, you probably want to use their versioning API, which may
- be based on this one, but is integrated with the rest of the
- library.
-
- Please note that internally the version is a long, but the API only
- allows you to set and retrieve int values. */
-objc_EXPORT void class_setVersion (Class class_, int version);
-
-/* Return the size in bytes (a byte is the size of a char) of an
- instance of the class. If class_ is Nil, return 0; else it return
- a non-zero number (since the 'isa' instance variable is required
- for all classes). */
-objc_EXPORT size_t class_getInstanceSize (Class class_);
-
-/* Change the implementation of the method. It also searches all
- classes for any class implementing the method, and replaces the
- existing implementation with the new one. For that to work,
- 'method' must be a method returned by class_getInstanceMethod() or
- class_getClassMethod() as the matching is done by comparing the
- pointers; in that case, only the implementation in the class is
- modified. Return the previous implementation that has been
- replaced. If method or implementation is NULL, do nothing and
- return NULL. */
-objc_EXPORT IMP
-method_setImplementation (Method method, IMP implementation);
-
-/* Swap the implementation of two methods in a single, atomic
- operation. This is equivalent to getting the implementation of
- each method and then calling method_setImplementation() on the
- other one. For this to work, the two methods must have been
- returned by class_getInstanceMethod() or class_getClassMethod().
- If 'method_a' or 'method_b' is NULL, do nothing. */
-objc_EXPORT void
-method_exchangeImplementations (Method method_a, Method method_b);
-
-/* Create a new class/meta-class pair. This function is called to
- create a new class at runtime. The class is created with
- superclass 'superclass' (use 'Nil' to create a new root class) and
- name 'class_name'. 'extraBytes' can be used to specify some extra
- space for indexed variables to be added at the end of the class and
- meta-class objects (it is recommended that you set extraBytes to
- 0). Once you have created the class, it is not usable yet. You
- need to add any instance variables (by using class_addIvar()), any
- instance methods (by using class_addMethod()) and any class methods
- (by using class_addMethod() on the meta-class, as in
- class_addMethod (object_getClass (class), method)) that are
- required, and then you need to call objc_registerClassPair() to
- activate the class. If you need to create a hierarchy of classes,
- you need to create and register them one at a time. You cannot
- create a new class using another class in construction as
- superclass. Return Nil if 'class-name' is NULL or if a class with
- that name already exists or 'superclass' is a class still in
- construction.
-
- Implementation Note: in the GNU runtime, allocating a class pair
- only creates the structures for the class pair, but does not
- register anything with the runtime. The class is registered with
- the runtime only when objc_registerClassPair() is called. In
- particular, if a class is in construction, objc_getClass() will not
- find it, the superclass will not know about it,
- class_getSuperclass() will return Nil and another thread may
- allocate a class pair with the same name; the conflict will only be
- detected when the classes are registered with the runtime.
- */
-objc_EXPORT Class
-objc_allocateClassPair (Class super_class, const char *class_name,
- size_t extraBytes);
-
-/* Register a class pair that was created with
- objc_allocateClassPair(). After you register a class, you can no
- longer make changes to its instance variables, but you can start
- creating instances of it. Do nothing if 'class_' is NULL or if it
- is not a class allocated by objc_allocateClassPair() and still in
- construction. */
-objc_EXPORT void
-objc_registerClassPair (Class class_);
-
-/* Dispose of a class pair created using objc_allocateClassPair().
- Call this function if you started creating a new class with
- objc_allocateClassPair() but then want to abort the process. You
- should not access 'class_' after calling this method. Note that if
- 'class_' has already been registered with the runtime via
- objc_registerClassPair(), this function does nothing; you can only
- dispose of class pairs that are still being constructed. Do
- nothing if class is 'Nil' or if 'class_' is not a class being
- constructed. */
-objc_EXPORT void
-objc_disposeClassPair (Class class_);
-
-/* Compatibility Note: The Apple/NeXT runtime has the function
- objc_duplicateClass () but it's undocumented. The GNU runtime does
- not have it. */
-
-
-/** Implementation: the following functions are in sendmsg.c. */
-
-/* Return the instance method with selector 'selector' of class
- 'class_', or NULL if the class (or one of its superclasses) does
- not implement the method. Return NULL if class_ is Nil or selector
- is NULL. Calling this function may trigger a call to
- +resolveInstanceMethod:, but does not return a forwarding
- function. */
-objc_EXPORT Method class_getInstanceMethod (Class class_, SEL selector);
-
-/* Return the class method with selector 'selector' of class 'class_',
- or NULL if the class (or one of its superclasses) does not
- implement the method. Return NULL if class_ is Nil or selector is
- NULL. Calling this function may trigger a call to
- +resolveClassMethod:, but does not return a forwarding
- function. */
-objc_EXPORT Method class_getClassMethod (Class class_, SEL selector);
-
-/* Return the IMP (pointer to the function implementing a method) for
- the instance method with selector 'selector' in class 'class_'.
- This is the same routine that is used while messaging, and should
- be very fast. Note that you most likely would need to cast the
- return function pointer to a function pointer with the appropriate
- arguments and return type before calling it. To get a class
- method, you can pass the meta-class as the class_ argument (ie, use
- class_getMethodImplementation (object_getClass (class_),
- selector)). Return NULL if class_ is Nil or selector is NULL.
- This function first looks for an existing method; if it is not
- found, it calls +resolveClassMethod: or +resolveInstanceMethod:
- (depending on whether a class or instance method is being looked
- up) if it is implemented. If the method returns YES, then it tries
- the look up again (the assumption being that +resolveClassMethod:
- or resolveInstanceMethod: will add the method using
- class_addMethod()). If it is still not found, it returns a
- forwarding function. */
-objc_EXPORT IMP class_getMethodImplementation (Class class_, SEL selector);
-
-/* Compatibility Note: the Apple/NeXT runtime has the function
- class_getMethodImplementation_stret () which currently does not
- exist on the GNU runtime because the messaging implementation is
- different. */
-
-/* Return YES if class 'class_' has an instance method implementing
- selector 'selector', and NO if not. Return NO if class_ is Nil or
- selector is NULL. If you need to check a class method, use the
- meta-class as the class_ argument (ie, use class_respondsToSelector
- (object_getClass (class_), selector)). */
-objc_EXPORT BOOL class_respondsToSelector (Class class_, SEL selector);
-
-/* Add a method to a class. Use this function to add a new method to
- a class (potentially overriding a method with the same selector in
- the superclass); if you want to modify an existing method, use
- method_setImplementation() instead (or class_replaceMethod ()).
- This method adds an instance method to 'class_'; to add a class
- method, get the meta class first, then add the method to the meta
- class, that is, use
-
- class_addMethod (object_getClass (class_), selector,
- implementation, type);
-
- Return YES if the method was added, and NO if not. Do nothing if
- one of the arguments is NULL. */
-objc_EXPORT BOOL class_addMethod (Class class_, SEL selector, IMP implementation,
- const char *method_types);
-
-/* Replace a method in a class. If the class already have a method
- with this 'selector', find it and use method_setImplementation() to
- replace the implementation with 'implementation' (method_types is
- ignored in that case). If the class does not already have a method
- with this 'selector', call 'class_addMethod() to add it.
-
- Return the previous implementation of the method, or NULL if none
- was found. Return NULL if any of the arguments is NULL. */
-objc_EXPORT IMP class_replaceMethod (Class class_, SEL selector, IMP implementation,
- const char *method_types);
-
-
-/** Implementation: the following functions are in methods.c. */
-
-/* Return the selector for method 'method'. Return NULL if 'method'
- is NULL.
-
- This function is misnamed; it should be called
- 'method_getSelector'. To get the actual name, get the selector,
- then the name from the selector (ie, use sel_getName
- (method_getName (method))). */
-objc_EXPORT SEL method_getName (Method method);
-
-/* Return the IMP of the method. Return NULL if 'method' is NULL. */
-objc_EXPORT IMP method_getImplementation (Method method);
-
-/* Return the type encoding of the method. Return NULL if 'method' is
- NULL. */
-objc_EXPORT const char * method_getTypeEncoding (Method method);
-
-/* Return a method description for the method. Return NULL if
- 'method' is NULL. */
-objc_EXPORT struct objc_method_description * method_getDescription (Method method);
-
-/* Return all the instance methods of the class. The return value of
- the function is a pointer to an area, allocated with malloc(), that
- contains all the instance methods of the class. It does not
- include instance methods of superclasses. The list is terminated
- by NULL. Optionally, if you pass a non-NULL
- 'numberOfReturnedMethods' pointer, the unsigned int that it points
- to will be filled with the number of instance methods returned. To
- get the list of class methods, pass the meta-class in the 'class_'
- argument, (ie, use class_copyMethodList (object_getClass (class_),
- &numberOfReturnedMethods)). */
-objc_EXPORT Method * class_copyMethodList (Class class_, unsigned int *numberOfReturnedMethods);
-
-
-/** Implementation: the following functions are in encoding.c. */
-
-/* Return the number of arguments that the method 'method' expects.
- Note that all methods need two implicit arguments ('self' for the
- receiver, and '_cmd' for the selector). Return 0 if 'method' is
- NULL. */
-objc_EXPORT unsigned int method_getNumberOfArguments (Method method);
-
-/* Return the string encoding for the return type of method 'method'.
- The string is a standard zero-terminated string in an area of
- memory allocated with malloc(); you should free it with free() when
- you finish using it. Return an empty string if method is NULL. */
-objc_EXPORT char * method_copyReturnType (Method method);
-
-/* Return the string encoding for the argument type of method
- 'method', argument number 'argumentNumber' ('argumentNumber' is 0
- for self, 1 for _cmd, and 2 or more for the additional arguments if
- any). The string is a standard zero-terminated string in an area
- of memory allocated with malloc(); you should free it with free()
- when you finish using it. Return an empty string if method is NULL
- or if 'argumentNumber' refers to a non-existing argument. */
-objc_EXPORT char * method_copyArgumentType (Method method, unsigned int argumentNumber);
-
-/* Return the string encoding for the return type of method 'method'.
- The string is returned by copying it into the supplied
- 'returnValue' string, which is of size 'returnValueSize'. No more
- than 'returnValueSize' characters are copied; if the encoding is
- smaller than 'returnValueSize', the rest of 'returnValue' is filled
- with zeros. If it is bigger, it is truncated (and would not be
- zero-terminated). You should supply a big enough
- 'returnValueSize'. If the method is NULL, returnValue is set to a
- string of zeros. */
-objc_EXPORT void method_getReturnType (Method method, char *returnValue,
- size_t returnValueSize);
-
-/* Return the string encoding for the argument type of method
- 'method', argument number 'argumentNumber' ('argumentNumber' is 0
- for self, 1 for _cmd, and 2 or more for the additional arguments if
- any). The string is returned by copying it into the supplied
- 'returnValue' string, which is of size 'returnValueSize'. No more
- than 'returnValueSize' characters are copied; if the encoding is
- smaller than 'returnValueSize', the rest of 'returnValue' is filled
- with zeros. If it is bigger, it is truncated (and would not be
- zero-terminated). You should supply a big enough
- 'returnValueSize'. If the method is NULL, returnValue is set to a
- string of zeros. */
-objc_EXPORT void method_getArgumentType (Method method, unsigned int argumentNumber,
- char *returnValue, size_t returnValueSize);
-
-
-/** Implementation: the following functions are in protocols.c. */
-
-/* Return the protocol with name 'name', or nil if it the protocol is
- not known to the runtime. */
-objc_EXPORT Protocol *objc_getProtocol (const char *name);
-
-/* Return all the protocols known to the runtime. The return value of
- the function is a pointer to an area, allocated with malloc(), that
- contains all the protocols known to the runtime; the list is
- terminated by NULL. You should free this area using free() once
- you no longer need it. Optionally, if you pass a non-NULL
- 'numberOfReturnedProtocols' pointer, the unsigned int that it
- points to will be filled with the number of protocols returned. If
- there are no protocols known to the runtime, NULL is returned. */
-objc_EXPORT Protocol **objc_copyProtocolList (unsigned int *numberOfReturnedProtocols);
-
-/* Add a protocol to a class, and return YES if it was done
- successfully, and NO if not. At the moment, NO should only happen
- if class_ or protocol are nil, if the protocol is not a Protocol
- object or if the class already conforms to the protocol. */
-objc_EXPORT BOOL class_addProtocol (Class class_, Protocol *protocol);
-
-/* Return YES if the class 'class_' conforms to Protocol 'protocol',
- and NO if not. This function does not check superclasses; if you
- want to check for superclasses (in the way that [NSObject
- +conformsToProtocol:] does) you need to iterate over the class
- hierarchy using class_getSuperclass(), and call
- class_conformsToProtocol() for each of them. */
-objc_EXPORT BOOL class_conformsToProtocol (Class class_, Protocol *protocol);
-
-/* Return all the protocols that the class conforms to. The return
- value of the function is a pointer to an area, allocated with
- malloc(), that contains all the protocols formally adopted by the
- class. It does not include protocols adopted by superclasses. The
- list is terminated by NULL. Optionally, if you pass a non-NULL
- 'numberOfReturnedProtocols' pointer, the unsigned int that it
- points to will be filled with the number of protocols returned.
- This function does not return protocols that superclasses conform
- to. */
-objc_EXPORT Protocol **class_copyProtocolList (Class class_, unsigned int *numberOfReturnedProtocols);
-
-/* Return YES if protocol 'protocol' conforms to protocol
- 'anotherProtocol', and NO if not. Note that if one of the two
- protocols is nil, it returns NO. */
-objc_EXPORT BOOL protocol_conformsToProtocol (Protocol *protocol, Protocol *anotherProtocol);
-
-/* Return YES if protocol 'protocol' is the same as protocol
- 'anotherProtocol', and 'NO' if not. Note that it returns YES if
- the two protocols are both nil. */
-objc_EXPORT BOOL protocol_isEqual (Protocol *protocol, Protocol *anotherProtocol);
-
-/* Return the name of protocol 'protocol'. If 'protocol' is nil or is
- not a Protocol, return NULL. */
-objc_EXPORT const char *protocol_getName (Protocol *protocol);
-
-/* Return the method description for the method with selector
- 'selector' in protocol 'protocol'; if 'requiredMethod' is YES, the
- function searches the list of required methods; if NO, the list of
- optional methods. If 'instanceMethod' is YES, the function search
- for an instance method; if NO, for a class method. If there is no
- matching method, an objc_method_description structure with both
- name and types set to NULL is returned. This function will only
- find methods that are directly declared in the protocol itself, not
- in other protocols that this protocol adopts.
-
- Note that the traditional ABI does not store the list of optional
- methods of a protocol in a compiled module, so the traditional ABI
- will always return (NULL, NULL) when requiredMethod == NO. */
-objc_EXPORT struct objc_method_description protocol_getMethodDescription (Protocol *protocol,
- SEL selector,
- BOOL requiredMethod,
- BOOL instanceMethod);
-
-/* Return the method descriptions of all the methods of the protocol.
- The return value of the function is a pointer to an area, allocated
- with malloc(), that contains all the method descriptions of the
- methods of the protocol. It does not recursively include methods
- of the protocols adopted by this protocol. The list is terminated
- by a NULL objc_method_description (one with both fields set to
- NULL). Optionally, if you pass a non-NULL
- 'numberOfReturnedMethods' pointer, the unsigned int that it points
- to will be filled with the number of properties returned.
-
- Note that the traditional ABI does not store the list of optional
- methods of a protocol in a compiled module, so the traditional ABI
- will always return an empty list if requiredMethod is set to
- NO. */
-objc_EXPORT struct objc_method_description *protocol_copyMethodDescriptionList (Protocol *protocol,
- BOOL requiredMethod,
- BOOL instanceMethod,
- unsigned int *numberOfReturnedMethods);
-
-/* Return the property with name 'propertyName' of the protocol
- 'protocol'. If 'requiredProperty' is YES, the function searches
- the list of required properties; if NO, the list of optional
- properties. If 'instanceProperty' is YES, the function searches
- the list of instance properties; if NO, the list of class
- properties. At the moment, optional properties and class
- properties are not part of the Objective-C language, so both
- 'requiredProperty' and 'instanceProperty' should be set to YES.
- This function returns NULL if the required property cannot be
- found.
-
- Note that the traditional ABI does not store the list of properties
- of a protocol in a compiled module, so the traditional ABI will
- always return NULL. */
-objc_EXPORT Property protocol_getProperty (Protocol *protocol, const char *propertyName,
- BOOL requiredProperty, BOOL instanceProperty);
-
-/* Return all the properties of the protocol. The return value of the
- function is a pointer to an area, allocated with malloc(), that
- contains all the properties of the protocol. It does not
- recursively include properties of the protocols adopted by this
- protocol. The list is terminated by NULL. Optionally, if you pass
- a non-NULL 'numberOfReturnedProperties' pointer, the unsigned int
- that it points to will be filled with the number of properties
- returned.
-
- Note that the traditional ABI does not store the list of properties
- of a protocol in a compiled module, so the traditional ABI will
- always return NULL and store 0 in numberOfReturnedProperties. */
-objc_EXPORT Property *protocol_copyPropertyList (Protocol *protocol, unsigned int *numberOfReturnedProperties);
-
-/* Return all the protocols that the protocol conforms to. The return
- value of the function is a pointer to an area, allocated with
- malloc(), that contains all the protocols formally adopted by the
- protocol. It does not recursively include protocols adopted by the
- protocols adopted by this protocol. The list is terminated by
- NULL. Optionally, if you pass a non-NULL
- 'numberOfReturnedProtocols' pointer, the unsigned int that it
- points to will be filled with the number of protocols returned. */
-objc_EXPORT Protocol **protocol_copyProtocolList (Protocol *protocol, unsigned int *numberOfReturnedProtocols);
-
-
-/** Implementation: the following hook is in init.c. */
-
-/* This is a hook which is called by __objc_exec_class every time a
- class or a category is loaded into the runtime. This may e.g. help
- a dynamic loader determine the classes that have been loaded when
- an object file is dynamically linked in. */
-objc_EXPORT void (*_objc_load_callback)(Class _class, struct objc_category *category);
-
-
-/** Implementation: the following functions are in objc-foreach.c. */
-
-/* 'objc_enumerationMutation()' is called when a collection is
- mutated while being "fast enumerated". That is a hard error, and
- objc_enumerationMutation is called to deal with it. 'collection'
- is the collection object that was mutated during an enumeration.
-
- objc_enumerationMutation() will invoke the mutation handler if any
- is set. Then, it will abort the program.
-
- Compatibility note: the Apple runtime will not abort the program
- after calling the mutation handler. */
-objc_EXPORT void objc_enumerationMutation (id collection);
-
-/* 'objc_set_enumeration_mutation_handler' can be used to set a
- function that will be called (instead of aborting) when a fast
- enumeration is mutated during enumeration. The handler will be
- called with the 'collection' being mutated as the only argument and
- it should not return; it should either exit the program, or could
- throw an exception. The recommended implementation is to throw an
- exception - the user can then use exception handlers to deal with
- it.
-
- This function is not thread safe (other threads may be trying to
- invoke the enumeration mutation handler while you are changing it!)
- and should be called during during the program initialization
- before threads are started. It is mostly reserved for "Foundation"
- libraries; in the case of GNUstep, GNUstep Base may be using this
- function to improve the standard enumeration mutation handling.
- You probably shouldn't use this function unless you are writing
- your own Foundation library. */
-objc_EXPORT void objc_setEnumerationMutationHandler (void (*handler)(id));
-
-/* This structure (used during fast enumeration) is automatically
- defined by the compiler (it is as if this definition was always
- included in all Objective-C files). Note that it is usually
- defined again with the name of NSFastEnumeration by "Foundation"
- libraries such as GNUstep Base. And if NSFastEnumeration is
- defined, the compiler will use it instead of
- __objcFastEnumerationState when doing fast enumeration. */
-/*
-struct __objcFastEnumerationState
-{
- unsigned long state;
- id *itemsPtr;
- unsigned long *mutationsPtr;
- unsigned long extra[5];
-};
-*/
-
-
-/* Compatibility Note: The Apple/NeXT runtime has the functions
- objc_copyImageNames (), class_getImageName () and
- objc_copyClassNamesForImage () but they are undocumented. The GNU
- runtime does not have them at the moment. */
-
-/* Compatibility Note: The Apple/NeXT runtime has the functions
- objc_setAssociatedObject (), objc_getAssociatedObject (),
- objc_removeAssociatedObjects () and the objc_AssociationPolicy type
- and related enum. The GNU runtime does not have them yet.
- TODO: Implement them. */
-
-/* Compatibility Note: The Apple/NeXT runtime has the function
- objc_setForwardHandler (). The GNU runtime does not have it
- because messaging (and, in particular, forwarding) works in a
- different (incompatible) way with the GNU runtime. If you need to
- customize message forwarding at the Objective-C runtime level (that
- is, if you are implementing your own "Foundation" library such as
- GNUstep Base on top of the Objective-C runtime), in objc/message.h
- there are hooks (that work in the framework of the GNU runtime) to
- do so. */
-
-
-/** Implementation: the following functions are in memory.c. */
-
-/* Traditional GNU Objective-C Runtime functions that are used for
- memory allocation and disposal. These functions are used in the
- same way as you use malloc, realloc, calloc and free and make sure
- that memory allocation works properly with the garbage
- collector.
-
- Compatibility Note: these functions are not available with the
- Apple/NeXT runtime. */
-
-objc_EXPORT void *objc_malloc(size_t size);
-
-/* FIXME: Shouldn't the following be called objc_malloc_atomic ? The
- GC function is GC_malloc_atomic() which makes sense.
- */
-objc_EXPORT void *objc_atomic_malloc(size_t size);
-
-objc_EXPORT void *objc_realloc(void *mem, size_t size);
-
-objc_EXPORT void *objc_calloc(size_t nelem, size_t size);
-
-objc_EXPORT void objc_free(void *mem);
-
-
-/** Implementation: the following functions are in gc.c. */
-
-/* The GNU Objective-C Runtime has a different implementation of
- garbage collection.
-
- Compatibility Note: these functions are not available with the
- Apple/NeXT runtime. */
-
-/* Mark the instance variable as inaccessible to the garbage
- collector. */
-objc_EXPORT void class_ivar_set_gcinvisible (Class _class,
- const char* ivarname,
- BOOL gcInvisible);
-
-
-/** Implementation: the following functions are in encoding.c. */
-
-/* Traditional GNU Objective-C Runtime functions that are currently
- used to implement method forwarding.
-
- Compatibility Note: these functions are not available with the
- Apple/NeXT runtime. */
-
-/* Return the size of a variable which has the specified 'type'
- encoding. */
-objc_EXPORT int objc_sizeof_type (const char *type);
-
-/* Return the align of a variable which has the specified 'type'
- encoding. */
-objc_EXPORT int objc_alignof_type (const char *type);
-
-/* Return the aligned size of a variable which has the specified
- 'type' encoding. The aligned size is the size rounded up to the
- nearest alignment. */
-objc_EXPORT int objc_aligned_size (const char *type);
-
-/* Return the promoted size of a variable which has the specified
- 'type' encoding. This is the size rounded up to the nearest
- integral of the wordsize, taken to be the size of a void *. */
-objc_EXPORT int objc_promoted_size (const char *type);
-
-
-/* The following functions are used when parsing the type encoding of
- methods, to skip over parts that are ignored. They take as
- argument a pointer to a location inside the type encoding of a
- method (which is a string) and return a new pointer, pointing to a
- new location inside the string after having skipped the unwanted
- information. */
-
-/* Skip some type qualifiers (_C_CONST, _C_IN, etc). These may
- eventually precede typespecs occurring in method prototype
- encodings. */
-objc_EXPORT const char *objc_skip_type_qualifiers (const char *type);
-
-/* Skip one typespec element (_C_CLASS, _C_SEL, etc). If the typespec
- is prepended by type qualifiers, these are skipped as well. */
-objc_EXPORT const char *objc_skip_typespec (const char *type);
-
-/* Skip an offset. */
-objc_EXPORT const char *objc_skip_offset (const char *type);
-
-/* Skip an argument specification (ie, skipping a typespec, which may
- include qualifiers, and an offset too). */
-objc_EXPORT const char *objc_skip_argspec (const char *type);
-
-/* Read type qualifiers (_C_CONST, _C_IN, etc) from string 'type'
- (stopping at the first non-type qualifier found) and return an
- unsigned int which is the logical OR of all the corresponding flags
- (_F_CONST, _F_IN etc). */
-objc_EXPORT unsigned objc_get_type_qualifiers (const char *type);
-
-
-/* Note that the following functions work for very simple structures,
- but get easily confused by more complicated ones (for example,
- containing vectors). A better solution is required. These
- functions are likely to change in the next GCC release. */
-
-/* The following three functions can be used to determine how a
- structure is laid out by the compiler. For example:
-
- struct objc_struct_layout layout;
- int i;
-
- objc_layout_structure (type, &layout);
- while (objc_layout_structure_next_member (&layout))
- {
- int position, align;
- const char *type;
-
- objc_layout_structure_get_info (&layout, &position, &align, &type);
- printf ("element %d has offset %d, alignment %d\n",
- i++, position, align);
- }
-
- These functions are used by objc_sizeof_type and objc_alignof_type
- functions to compute the size and alignment of structures. The
- previous method of computing the size and alignment of a structure
- was not working on some architectures, particularly on AIX, and in
- the presence of bitfields inside the structure. */
-struct objc_struct_layout
-{
- const char *original_type;
- const char *type;
- const char *prev_type;
- unsigned int record_size;
- unsigned int record_align;
-};
-
-objc_EXPORT void objc_layout_structure (const char *type,
- struct objc_struct_layout *layout);
-objc_EXPORT BOOL objc_layout_structure_next_member (struct objc_struct_layout *layout);
-objc_EXPORT void objc_layout_finish_structure (struct objc_struct_layout *layout,
- unsigned int *size,
- unsigned int *align);
-objc_EXPORT void objc_layout_structure_get_info (struct objc_struct_layout *layout,
- unsigned int *offset,
- unsigned int *align,
- const char **type);
-
-#ifdef __cplusplus
-}
-#endif /* __cplusplus */
-
-#endif
diff --git a/libgcobol/objc/thr.h b/libgcobol/objc/thr.h
deleted file mode 100644
index fedac917f77c..000000000000
--- a/libgcobol/objc/thr.h
+++ /dev/null
@@ -1,116 +0,0 @@
-/* Thread and mutex controls for Objective C.
- Copyright (C) 1996-2022 Free Software Foundation, Inc.
- Contributed by Galen C. Hunt (gchunt@cs.rochester.edu)
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#ifndef __thread_INCLUDE_GNU
-#define __thread_INCLUDE_GNU
-
-#include "objc.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif /* __cplusplus */
-
-/*************************************************************************
- * Universal static variables:
- */
-extern int __objc_thread_exit_status; /* Global exit status. */
-
-/********
- * Thread safe implementation types and functions.
- */
-
-/* Thread priorities */
-#define OBJC_THREAD_INTERACTIVE_PRIORITY 2
-#define OBJC_THREAD_BACKGROUND_PRIORITY 1
-#define OBJC_THREAD_LOW_PRIORITY 0
-
-/* A thread */
-typedef void * objc_thread_t;
-
-/* This structure represents a single mutual exclusion lock. */
-struct objc_mutex
-{
- volatile objc_thread_t owner; /* Id of thread that owns. */
- volatile int depth; /* # of acquires. */
- void * backend; /* Specific to backend */
-};
-typedef struct objc_mutex *objc_mutex_t;
-
-/* This structure represents a single condition mutex */
-struct objc_condition
-{
- void * backend; /* Specific to backend */
-};
-typedef struct objc_condition *objc_condition_t;
-
-/* Frontend mutex functions */
-objc_mutex_t objc_mutex_allocate (void);
-int objc_mutex_deallocate (objc_mutex_t mutex);
-int objc_mutex_lock (objc_mutex_t mutex);
-int objc_mutex_unlock (objc_mutex_t mutex);
-int objc_mutex_trylock (objc_mutex_t mutex);
-
-/* Frontend condition mutex functions */
-objc_condition_t objc_condition_allocate (void);
-int objc_condition_deallocate (objc_condition_t condition);
-int objc_condition_wait (objc_condition_t condition, objc_mutex_t mutex);
-int objc_condition_signal (objc_condition_t condition);
-int objc_condition_broadcast (objc_condition_t condition);
-
-/* Frontend thread functions */
-objc_thread_t objc_thread_detach (SEL selector, id object, id argument);
-void objc_thread_yield (void);
-int objc_thread_exit (void);
-int objc_thread_set_priority (int priority);
-int objc_thread_get_priority (void);
-void * objc_thread_get_data (void);
-int objc_thread_set_data (void *value);
-objc_thread_t objc_thread_id (void);
-void objc_thread_add (void);
-void objc_thread_remove (void);
-
-/*
- Use this to set the hook function that will be called when the
- runtime initially becomes multi threaded.
- The hook function is only called once, meaning only when the
- 2nd thread is spawned, not for each and every thread.
-
- It returns the previous hook function or NULL if there is none.
-
- A program outside of the runtime could set this to some function so
- it can be informed; for example, the GNUstep Base Library sets it
- so it can implement the NSBecomingMultiThreaded notification.
- */
-typedef void (*objc_thread_callback) (void);
-objc_thread_callback objc_set_thread_callback (objc_thread_callback func);
-
-/* Backend initialization functions */
-int __objc_init_thread_system (void);
-
-#ifdef __cplusplus
-}
-#endif /* __cplusplus */
-
-#endif /* not __thread_INCLUDE_GNU */
diff --git a/libgcobol/objects.c b/libgcobol/objects.c
deleted file mode 100644
index 3c66f0dc084f..000000000000
--- a/libgcobol/objects.c
+++ /dev/null
@@ -1,118 +0,0 @@
-/* GNU Objective C Runtime class related functions
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc/thr.h" /* Required by objc-private/runtime.h. */
-#include "objc-private/module-abi-8.h" /* For CLS_ISCLASS and similar. */
-#include "objc-private/runtime.h" /* the kitchen sink */
-
-#include <string.h> /* For memcpy() */
-
-#if OBJC_WITH_GC
-# include <gc/gc.h>
-# include <gc/gc_typed.h>
-#endif
-
-/* FIXME: The semantics of extraBytes are not really clear. */
-inline
-id
-class_createInstance (Class class, size_t extraBytes)
-{
- id new = nil;
-
-#if OBJC_WITH_GC
- if (CLS_ISCLASS (class))
- new = (id) GC_malloc_explicitly_typed (class->instance_size + extraBytes,
- (GC_descr)class->gc_object_type);
-#else
- if (CLS_ISCLASS (class))
- new = (id) objc_calloc (class->instance_size + extraBytes, 1);
-#endif
-
- if (new != nil)
- {
- /* There is no need to zero the memory, since both
- GC_malloc_explicitly_typed and objc_calloc return zeroed
- memory. */
- new->class_pointer = class;
- }
-
- /* TODO: Invoke C++ constructors on all appropriate C++ instance
- variables of the new object. */
-
- return new;
-}
-
-/* Traditional GNU Objective-C Runtime API. */
-id
-object_copy (id object, size_t extraBytes)
-{
- if ((object != nil) && CLS_ISCLASS (object->class_pointer))
- {
- /* TODO: How should it work with C++ constructors ? */
- id copy = class_createInstance (object->class_pointer, extraBytes);
- memcpy (copy, object, object->class_pointer->instance_size + extraBytes);
- return copy;
- }
- else
- return nil;
-}
-
-id
-object_dispose (id object)
-{
- if ((object != nil) && CLS_ISCLASS (object->class_pointer))
- {
- /* TODO: Invoke C++ destructors on all appropriate C++ instance
- variables. But what happens with the garbage collector ?
- Would object_dispose() be ever called in that case ? */
-
- objc_free (object);
- }
- return nil;
-}
-
-const char *
-object_getClassName (id object)
-{
- if (object != nil)
- return object->class_pointer->name;
- else
- return "Nil";
-}
-
-Class
-object_setClass (id object, Class class_)
-{
- if (object == nil)
- return Nil;
- else
- {
- Class old_class = object->class_pointer;
-
- object->class_pointer = class_;
- return old_class;
- }
-}
diff --git a/libgcobol/protocols.c b/libgcobol/protocols.c
deleted file mode 100644
index 4d672a447b07..000000000000
--- a/libgcobol/protocols.c
+++ /dev/null
@@ -1,557 +0,0 @@
-/* GNU Objective C Runtime protocol related functions.
- Copyright (C) 2010-2022 Free Software Foundation, Inc.
- Contributed by Nicola Pero
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h" /* For runtime structures */
-#include "objc/thr.h"
-#include "objc-private/runtime.h" /* the kitchen sink */
-#include "objc-private/hash.h" /* For the hash table of protocols. */
-#include "objc-private/protocols.h" /* For __objc_protocols_init() and
- __objc_protocols_add_protocol(). */
-#include <stdlib.h> /* For malloc. */
-
-/* This is a table that maps a name to a Protocol instance with that
- name. Because there may be multiple Protocol instances with the
- same name (no harm in that) the table records only one
- instance. */
-static cache_ptr __protocols_hashtable;
-
-/* A mutex protecting the protocol_hashtable. */
-static objc_mutex_t __protocols_hashtable_lock = NULL;
-
-/* Called at startup by init.c. */
-void
-__objc_protocols_init (void)
-{
- __protocols_hashtable_lock = objc_mutex_allocate ();
-
- /* The keys in the table are strings, and the values are Protocol
- objects. */
- __protocols_hashtable = objc_hash_new (64, (hash_func_type) objc_hash_string,
- (compare_func_type) objc_compare_strings);
-}
-
-/* Add a protocol to the hashtable. */
-void
-__objc_protocols_add_protocol (const char *name, struct objc_protocol *object)
-{
- objc_mutex_lock (__protocols_hashtable_lock);
-
- /* If we find a protocol with the same name already in the
- hashtable, we do not need to add the new one, because it will be
- identical to it. This in the reasonable assumption that two
- protocols with the same name are identical, which is expected in
- any sane program. If we are really paranoid, we would compare
- the protocols and abort if they are not identical.
- Unfortunately, this would slow down the startup of all
- Objective-C programs while trying to catch a problem that has
- never been seen in practice, so we don't do it. */
- if (! objc_hash_is_key_in_hash (__protocols_hashtable, name))
- objc_hash_add (&__protocols_hashtable, name, object);
-
- objc_mutex_unlock (__protocols_hashtable_lock);
-}
-
-Protocol *
-objc_getProtocol (const char *name)
-{
- Protocol *protocol;
-
- if (name == NULL)
- return NULL;
-
- objc_mutex_lock (__protocols_hashtable_lock);
- protocol = (Protocol *)(objc_hash_value_for_key (__protocols_hashtable, name));
- objc_mutex_unlock (__protocols_hashtable_lock);
-
- return protocol;
-}
-
-Protocol **
-objc_copyProtocolList (unsigned int *numberOfReturnedProtocols)
-{
- unsigned int count = 0;
- Protocol **returnValue = NULL;
- node_ptr node;
-
- objc_mutex_lock (__protocols_hashtable_lock);
-
- /* Count how many protocols we have. */
- node = objc_hash_next (__protocols_hashtable, NULL);
- while (node)
- {
- count++;
- node = objc_hash_next (__protocols_hashtable, node);
- }
-
- if (count != 0)
- {
- unsigned int i = 0;
-
- /* Allocate enough memory to hold them. */
- returnValue = (Protocol **)(malloc (sizeof (Protocol *) * (count + 1)));
-
- /* Copy the protocols. */
- node = objc_hash_next (__protocols_hashtable, NULL);
- while (node)
- {
- returnValue[i] = node->value;
- i++;
- node = objc_hash_next (__protocols_hashtable, node);
- }
-
- returnValue[i] = NULL;
- }
- objc_mutex_unlock (__protocols_hashtable_lock);
-
- if (numberOfReturnedProtocols)
- *numberOfReturnedProtocols = count;
-
- return returnValue;
-}
-
-BOOL
-class_addProtocol (Class class_, Protocol *protocol)
-{
- struct objc_protocol_list *protocols;
-
- if (class_ == Nil || protocol == NULL)
- return NO;
-
- if (class_conformsToProtocol (class_, protocol))
- return NO;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NO;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Create the objc_protocol_list. */
- protocols = malloc (sizeof (struct objc_protocol_list));
- protocols->count = 1;
- protocols->list[0] = (struct objc_protocol *)protocol;
-
- /* Attach it to the list of class protocols. */
- protocols->next = class_->protocols;
- class_->protocols = protocols;
-
- objc_mutex_unlock (__objc_runtime_mutex);
-
- return YES;
-}
-
-BOOL
-class_conformsToProtocol (Class class_, Protocol *protocol)
-{
- struct objc_protocol_list* proto_list;
-
- if (class_ == Nil || protocol == NULL)
- return NO;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NO;
-
- /* Acquire the runtime lock because the list of protocols for a
- class may be modified concurrently, for example if another thread
- calls class_addProtocol(), or dynamically loads from a file a
- category of the class. */
- objc_mutex_lock (__objc_runtime_mutex);
- proto_list = class_->protocols;
-
- while (proto_list)
- {
- size_t i;
- for (i = 0; i < proto_list->count; i++)
- {
- if (proto_list->list[i] == (struct objc_protocol *)protocol
- || protocol_conformsToProtocol ((Protocol *)proto_list->list[i],
- protocol))
- {
- objc_mutex_unlock (__objc_runtime_mutex);
- return YES;
- }
- }
- proto_list = proto_list->next;
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
- return NO;
-}
-
-Protocol **
-class_copyProtocolList (Class class_, unsigned int *numberOfReturnedProtocols)
-{
- unsigned int count = 0;
- Protocol **returnValue = NULL;
- struct objc_protocol_list* proto_list;
-
- if (class_ == Nil)
- {
- if (numberOfReturnedProtocols)
- *numberOfReturnedProtocols = 0;
- return NULL;
- }
-
- /* Lock the runtime mutex because the class protocols may be
- concurrently modified. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Count how many protocols we have. */
- proto_list = class_->protocols;
-
- while (proto_list)
- {
- count = count + proto_list->count;
- proto_list = proto_list->next;
- }
-
- if (count != 0)
- {
- unsigned int i = 0;
-
- /* Allocate enough memory to hold them. */
- returnValue = (Protocol **)(malloc (sizeof (Protocol *) * (count + 1)));
-
- /* Copy the protocols. */
- proto_list = class_->protocols;
-
- while (proto_list)
- {
- size_t j;
- for (j = 0; j < proto_list->count; j++)
- {
- returnValue[i] = (Protocol *)proto_list->list[j];
- i++;
- }
- proto_list = proto_list->next;
- }
-
- returnValue[i] = NULL;
- }
- objc_mutex_unlock (__objc_runtime_mutex);
-
- if (numberOfReturnedProtocols)
- *numberOfReturnedProtocols = count;
-
- return returnValue;
-}
-
-BOOL
-protocol_conformsToProtocol (Protocol *protocol, Protocol *anotherProtocol)
-{
- struct objc_protocol_list* proto_list;
-
- if (protocol == NULL || anotherProtocol == NULL)
- return NO;
-
- if (protocol == anotherProtocol)
- return YES;
-
- /* Check that the objects are Protocol objects before casting them
- to (struct objc_protocol *). */
- if (protocol->class_pointer != anotherProtocol->class_pointer)
- return NO;
-
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NO;
-
- if (strcmp (((struct objc_protocol *)protocol)->protocol_name,
- ((struct objc_protocol *)anotherProtocol)->protocol_name) == 0)
- return YES;
-
- /* We do not acquire any lock because protocols are currently
- immutable. We can freely iterate over a protocol structure. */
- proto_list = ((struct objc_protocol *)protocol)->protocol_list;
- while (proto_list)
- {
- size_t i;
-
- for (i = 0; i < proto_list->count; i++)
- {
- if (protocol_conformsToProtocol ((Protocol *)proto_list->list[i], anotherProtocol))
- return YES;
- }
- proto_list = proto_list->next;
- }
-
- return NO;
-}
-
-BOOL
-protocol_isEqual (Protocol *protocol, Protocol *anotherProtocol)
-{
- if (protocol == anotherProtocol)
- return YES;
-
- if (protocol == NULL || anotherProtocol == NULL)
- return NO;
-
- /* Check that the objects are Protocol objects before casting them
- to (struct objc_protocol *). */
- if (protocol->class_pointer != anotherProtocol->class_pointer)
- return NO;
-
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NO;
-
- /* Equality between formal protocols is only formal (nothing to do
- with actually checking the list of methods they have!). Two
- formal Protocols are equal if and only if they have the same
- name.
-
- Please note (for comparisons with other implementations) that
- checking the names is equivalent to checking that Protocol A
- conforms to Protocol B and Protocol B conforms to Protocol A,
- because this happens iff they have the same name. If they have
- different names, A conforms to B if and only if A includes B, but
- the situation where A includes B and B includes A is a circular
- dependency between Protocols which is forbidden by the compiler,
- so A conforms to B and B conforms to A with A and B having
- different names is an impossible case. */
- if (strcmp (((struct objc_protocol *)protocol)->protocol_name,
- ((struct objc_protocol *)anotherProtocol)->protocol_name) == 0)
- return YES;
-
- return NO;
-}
-
-const char *
-protocol_getName (Protocol *protocol)
-{
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NULL;
-
- return ((struct objc_protocol *)protocol)->protocol_name;
-}
-
-struct objc_method_description protocol_getMethodDescription (Protocol *protocol,
- SEL selector,
- BOOL requiredMethod,
- BOOL instanceMethod)
-{
- struct objc_method_description no_result = { NULL, NULL };
- struct objc_method_description_list *methods;
- int i;
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on optional protocol methods. */
- if (! requiredMethod)
- return no_result;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return no_result;
-
- if (instanceMethod)
- methods = ((struct objc_protocol *)protocol)->instance_methods;
- else
- methods = ((struct objc_protocol *)protocol)->class_methods;
-
- if (methods)
- {
- for (i = 0; i < methods->count; i++)
- {
- if (sel_isEqual (methods->list[i].name, selector))
- return methods->list[i];
- /*
- if (strcmp (sel_getName (methods->list[i].name), selector_name) == 0)
- return methods->list[i];
- */
- }
- }
-
- return no_result;
-}
-
-struct objc_method_description *protocol_copyMethodDescriptionList (Protocol *protocol,
- BOOL requiredMethod,
- BOOL instanceMethod,
- unsigned int *numberOfReturnedMethods)
-{
- struct objc_method_description_list *methods;
- unsigned int count = 0;
- struct objc_method_description *returnValue = NULL;
-
- /* TODO: New ABI */
- /* The current ABI does not have any information on optional protocol methods. */
- if (! requiredMethod)
- {
- if (numberOfReturnedMethods)
- *numberOfReturnedMethods = 0;
-
- return NULL;
- }
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol == NULL || protocol->class_pointer != objc_lookUpClass ("Protocol"))
- {
- if (numberOfReturnedMethods)
- *numberOfReturnedMethods = 0;
-
- return NULL;
- }
-
- /* We do not acquire any lock because protocols are currently
- immutable. We can freely iterate over a protocol structure. */
-
- if (instanceMethod)
- methods = ((struct objc_protocol *)protocol)->instance_methods;
- else
- methods = ((struct objc_protocol *)protocol)->class_methods;
-
- if (methods)
- {
- unsigned int i;
- count = methods->count;
-
- /* Allocate enough memory to hold them. */
- returnValue = (struct objc_method_description *)(malloc (sizeof (struct objc_method_description) * (count + 1)));
-
- /* Copy them. */
- for (i = 0; i < count; i++)
- {
- returnValue[i].name = methods->list[i].name;
- returnValue[i].types = methods->list[i].types;
- }
- returnValue[i].name = NULL;
- returnValue[i].types = NULL;
- }
-
- if (numberOfReturnedMethods)
- *numberOfReturnedMethods = count;
-
- return returnValue;
-}
-
-Property protocol_getProperty (Protocol *protocol, const char *propertyName,
- BOOL requiredProperty, BOOL instanceProperty)
-{
- if (protocol == NULL || propertyName == NULL)
- return NULL;
-
- if (!requiredProperty || !instanceProperty)
- return NULL;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol->class_pointer != objc_lookUpClass ("Protocol"))
- return NULL;
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on protocol properties. */
- return NULL;
-}
-
-Property *protocol_copyPropertyList (Protocol *protocol, unsigned int *numberOfReturnedProperties)
-{
- unsigned int count = 0;
- Property *returnValue = NULL;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol == NULL || protocol->class_pointer != objc_lookUpClass ("Protocol"))
- {
- if (numberOfReturnedProperties)
- *numberOfReturnedProperties = 0;
-
- return NULL;
- }
-
- /* We do not acquire any lock because protocols are currently
- immutable. We can freely iterate over a protocol structure. */
-
- /* TODO: New ABI. */
- /* The current ABI does not have any information on protocol properties. */
- if (numberOfReturnedProperties)
- *numberOfReturnedProperties = count;
-
- return returnValue;
-}
-
-Protocol **protocol_copyProtocolList (Protocol *protocol, unsigned int *numberOfReturnedProtocols)
-{
- unsigned int count = 0;
- Protocol **returnValue = NULL;
- struct objc_protocol_list* proto_list;
-
- /* Check that it is a Protocol object before casting it to (struct
- objc_protocol *). */
- if (protocol == NULL || protocol->class_pointer != objc_lookUpClass ("Protocol"))
- {
- if (numberOfReturnedProtocols)
- *numberOfReturnedProtocols = 0;
-
- return NULL;
- }
-
- /* We do not acquire any lock because protocols are currently
- immutable. We can freely iterate over a protocol structure. */
-
- /* Count how many protocols we have. */
- proto_list = ((struct objc_protocol *)protocol)->protocol_list;
-
- while (proto_list)
- {
- count = count + proto_list->count;
- proto_list = proto_list->next;
- }
-
- if (count != 0)
- {
- unsigned int i = 0;
-
- /* Allocate enough memory to hold them. */
- returnValue = (Protocol **)(malloc (sizeof (Protocol *) * (count + 1)));
-
- /* Copy the protocols. */
- proto_list = ((struct objc_protocol *)protocol)->protocol_list;
-
- while (proto_list)
- {
- size_t j;
- for (j = 0; j < proto_list->count; j++)
- {
- returnValue[i] = (Protocol *)proto_list->list[j];
- i++;
- }
- proto_list = proto_list->next;
- }
-
- returnValue[i] = NULL;
- }
-
- if (numberOfReturnedProtocols)
- *numberOfReturnedProtocols = count;
-
- return returnValue;
-}
diff --git a/libgcobol/sarray.c b/libgcobol/sarray.c
deleted file mode 100644
index 246aac1a0405..000000000000
--- a/libgcobol/sarray.c
+++ /dev/null
@@ -1,523 +0,0 @@
-/* Sparse Arrays for Objective C dispatch tables
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC 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, or (at your option)
-any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc-private/sarray.h"
-#include "objc/runtime.h" /* For objc_malloc */
-#include "objc/thr.h" /* For objc_mutex_lock */
-#include "objc-private/module-abi-8.h"
-#include "objc-private/runtime.h"
-#include <stdio.h>
-#include <string.h> /* For memset */
-#include <assert.h> /* For assert */
-
-int nbuckets = 0; /* !T:MUTEX */
-int nindices = 0; /* !T:MUTEX */
-int narrays = 0; /* !T:MUTEX */
-int idxsize = 0; /* !T:MUTEX */
-
-static void *first_free_data = NULL; /* !T:MUTEX */
-
-#ifdef OBJC_SPARSE2
-const char *__objc_sparse2_id = "2 level sparse indices";
-#endif
-
-#ifdef OBJC_SPARSE3
-const char *__objc_sparse3_id = "3 level sparse indices";
-#endif
-
-/* This function removes any structures left over from free operations
- that were not safe in a multi-threaded environment. */
-void
-sarray_remove_garbage (void)
-{
- void **vp;
- void *np;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- vp = first_free_data;
- first_free_data = NULL;
-
- while (vp)
- {
- np = *vp;
- objc_free (vp);
- vp = np;
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* Free a block of dynamically allocated memory. If we are in
- multi-threaded mode, it is ok to free it. If not, we add it to the
- garbage heap to be freed later. */
-static void
-sarray_free_garbage (void *vp)
-{
- objc_mutex_lock (__objc_runtime_mutex);
-
- if (__objc_runtime_threads_alive == 1)
- {
- objc_free (vp);
- if (first_free_data)
- sarray_remove_garbage ();
- }
- else
- {
- *(void **)vp = first_free_data;
- first_free_data = vp;
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* sarray_at_put copies data in such a way as to be thread reader
- safe. */
-void
-sarray_at_put (struct sarray *array, sidx index, void *element)
-{
-#ifdef OBJC_SPARSE3
- struct sindex **the_index;
- struct sindex *new_index;
-#endif
- struct sbucket **the_bucket;
- struct sbucket *new_bucket;
-#ifdef OBJC_SPARSE3
- size_t ioffset;
-#endif
- size_t boffset;
- size_t eoffset;
-#ifdef PRECOMPUTE_SELECTORS
- union sofftype xx;
- xx.idx = index;
-#ifdef OBJC_SPARSE3
- ioffset = xx.off.ioffset;
-#endif
- boffset = xx.off.boffset;
- eoffset = xx.off.eoffset;
-#else /* not PRECOMPUTE_SELECTORS */
-#ifdef OBJC_SPARSE3
- ioffset = index/INDEX_CAPACITY;
- boffset = (index/BUCKET_SIZE)%INDEX_SIZE;
- eoffset = index%BUCKET_SIZE;
-#else
- boffset = index/BUCKET_SIZE;
- eoffset = index%BUCKET_SIZE;
-#endif
-#endif /* not PRECOMPUTE_SELECTORS */
-
- assert (soffset_decode (index) < array->capacity); /* Range check */
-
-#ifdef OBJC_SPARSE3
- the_index = &(array->indices[ioffset]);
- the_bucket = &((*the_index)->buckets[boffset]);
-#else
- the_bucket = &(array->buckets[boffset]);
-#endif
-
- if ((*the_bucket)->elems[eoffset] == element)
- return; /* Great! we just avoided a lazy copy. */
-
-#ifdef OBJC_SPARSE3
-
- /* First, perform lazy copy/allocation of index if needed. */
-
- if ((*the_index) == array->empty_index)
- {
- /* The index was previously empty, allocate a new. */
- new_index = (struct sindex *) objc_malloc (sizeof (struct sindex));
- memcpy (new_index, array->empty_index, sizeof (struct sindex));
- new_index->version.version = array->version.version;
- *the_index = new_index; /* Prepared for install. */
- the_bucket = &((*the_index)->buckets[boffset]);
-
- nindices += 1;
- }
- else if ((*the_index)->version.version != array->version.version)
- {
- /* This index must be lazy copied. */
- struct sindex *old_index = *the_index;
- new_index = (struct sindex *) objc_malloc (sizeof (struct sindex));
- memcpy (new_index, old_index, sizeof (struct sindex));
- new_index->version.version = array->version.version;
- *the_index = new_index; /* Prepared for install. */
- the_bucket = &((*the_index)->buckets[boffset]);
-
- nindices += 1;
- }
-
-#endif /* OBJC_SPARSE3 */
-
- /* Next, perform lazy allocation/copy of the bucket if needed. */
- if ((*the_bucket) == array->empty_bucket)
- {
- /* The bucket was previously empty (or something like that),
- allocate a new. This is the effect of `lazy' allocation. */
- new_bucket = (struct sbucket *) objc_malloc (sizeof (struct sbucket));
- memcpy ((void *) new_bucket, (const void *) array->empty_bucket,
- sizeof (struct sbucket));
- new_bucket->version.version = array->version.version;
- *the_bucket = new_bucket; /* Prepared for install. */
-
- nbuckets += 1;
-
- }
- else if ((*the_bucket)->version.version != array->version.version)
- {
- /* Perform lazy copy. */
- struct sbucket *old_bucket = *the_bucket;
- new_bucket = (struct sbucket *) objc_malloc (sizeof (struct sbucket));
- memcpy (new_bucket, old_bucket, sizeof (struct sbucket));
- new_bucket->version.version = array->version.version;
- *the_bucket = new_bucket; /* Prepared for install. */
-
- nbuckets += 1;
- }
- (*the_bucket)->elems[eoffset] = element;
-}
-
-void
-sarray_at_put_safe (struct sarray *array, sidx index, void *element)
-{
- if (soffset_decode (index) >= array->capacity)
- sarray_realloc (array, soffset_decode (index) + 1);
- sarray_at_put (array, index, element);
-}
-
-struct sarray *
-sarray_new (int size, void *default_element)
-{
- struct sarray *arr;
-#ifdef OBJC_SPARSE3
- size_t num_indices = ((size - 1)/(INDEX_CAPACITY)) + 1;
- struct sindex **new_indices;
-#else /* OBJC_SPARSE2 */
- size_t num_indices = ((size - 1)/BUCKET_SIZE) + 1;
- struct sbucket **new_buckets;
-#endif
- size_t counter;
-
- assert (size > 0);
-
- /* Allocate core array. */
- arr = (struct sarray *) objc_malloc (sizeof (struct sarray));
- arr->version.version = 0;
-
- /* Initialize members. */
-#ifdef OBJC_SPARSE3
- arr->capacity = num_indices*INDEX_CAPACITY;
- new_indices = (struct sindex **)
- objc_malloc (sizeof (struct sindex *) * num_indices);
-
- arr->empty_index = (struct sindex *) objc_malloc (sizeof (struct sindex));
- arr->empty_index->version.version = 0;
-
- narrays += 1;
- idxsize += num_indices;
- nindices += 1;
-
-#else /* OBJC_SPARSE2 */
- arr->capacity = num_indices*BUCKET_SIZE;
- new_buckets = (struct sbucket **)
- objc_malloc (sizeof (struct sbucket *) * num_indices);
-
- narrays += 1;
- idxsize += num_indices;
-
-#endif
-
- arr->empty_bucket = (struct sbucket *) objc_malloc (sizeof (struct sbucket));
- arr->empty_bucket->version.version = 0;
-
- nbuckets += 1;
-
- arr->ref_count = 1;
- arr->is_copy_of = (struct sarray *) 0;
-
- for (counter = 0; counter < BUCKET_SIZE; counter++)
- arr->empty_bucket->elems[counter] = default_element;
-
-#ifdef OBJC_SPARSE3
- for (counter = 0; counter < INDEX_SIZE; counter++)
- arr->empty_index->buckets[counter] = arr->empty_bucket;
-
- for (counter = 0; counter < num_indices; counter++)
- new_indices[counter] = arr->empty_index;
-
-#else /* OBJC_SPARSE2 */
-
- for (counter = 0; counter < num_indices; counter++)
- new_buckets[counter] = arr->empty_bucket;
-
-#endif
-
-#ifdef OBJC_SPARSE3
- arr->indices = new_indices;
-#else /* OBJC_SPARSE2 */
- arr->buckets = new_buckets;
-#endif
-
- return arr;
-}
-
-
-/* Reallocate the sparse array to hold `newsize' entries Note: We
- really allocate and then free. We have to do this to ensure that
- any concurrent readers notice the update. */
-void
-sarray_realloc (struct sarray *array, int newsize)
-{
-#ifdef OBJC_SPARSE3
- size_t old_max_index = (array->capacity - 1)/INDEX_CAPACITY;
- size_t new_max_index = ((newsize - 1)/INDEX_CAPACITY);
- size_t rounded_size = (new_max_index + 1) * INDEX_CAPACITY;
-
- struct sindex **new_indices;
- struct sindex **old_indices;
-
-#else /* OBJC_SPARSE2 */
- size_t old_max_index = (array->capacity - 1)/BUCKET_SIZE;
- size_t new_max_index = ((newsize - 1)/BUCKET_SIZE);
- size_t rounded_size = (new_max_index + 1) * BUCKET_SIZE;
-
- struct sbucket **new_buckets;
- struct sbucket **old_buckets;
-
-#endif
-
- size_t counter;
-
- assert (newsize > 0);
-
- /* The size is the same, just ignore the request. */
- if (rounded_size <= array->capacity)
- return;
-
- assert (array->ref_count == 1); /* stop if lazy copied... */
-
- /* We are asked to extend the array -- allocate new bucket table,
- and insert empty_bucket in newly allocated places. */
- if (rounded_size > array->capacity)
- {
-#ifdef OBJC_SPARSE3
- new_max_index += 4;
- rounded_size = (new_max_index + 1) * INDEX_CAPACITY;
-#else /* OBJC_SPARSE2 */
- new_max_index += 4;
- rounded_size = (new_max_index + 1) * BUCKET_SIZE;
-#endif
-
- /* Update capacity. */
- array->capacity = rounded_size;
-
-#ifdef OBJC_SPARSE3
- /* Alloc to force re-read by any concurrent readers. */
- old_indices = array->indices;
- new_indices = (struct sindex **)
- objc_malloc ((new_max_index + 1) * sizeof (struct sindex *));
-#else /* OBJC_SPARSE2 */
- old_buckets = array->buckets;
- new_buckets = (struct sbucket **)
- objc_malloc ((new_max_index + 1) * sizeof (struct sbucket *));
-#endif
-
- /* Copy buckets below old_max_index (they are still valid). */
- for (counter = 0; counter <= old_max_index; counter++ )
- {
-#ifdef OBJC_SPARSE3
- new_indices[counter] = old_indices[counter];
-#else /* OBJC_SPARSE2 */
- new_buckets[counter] = old_buckets[counter];
-#endif
- }
-
-#ifdef OBJC_SPARSE3
- /* Reset entries above old_max_index to empty_bucket. */
- for (counter = old_max_index + 1; counter <= new_max_index; counter++)
- new_indices[counter] = array->empty_index;
-#else /* OBJC_SPARSE2 */
- /* Reset entries above old_max_index to empty_bucket. */
- for (counter = old_max_index + 1; counter <= new_max_index; counter++)
- new_buckets[counter] = array->empty_bucket;
-#endif
-
-#ifdef OBJC_SPARSE3
- /* Install the new indices. */
- array->indices = new_indices;
-#else /* OBJC_SPARSE2 */
- array->buckets = new_buckets;
-#endif
-
-#ifdef OBJC_SPARSE3
- /* Free the old indices. */
- sarray_free_garbage (old_indices);
-#else /* OBJC_SPARSE2 */
- sarray_free_garbage (old_buckets);
-#endif
-
- idxsize += (new_max_index-old_max_index);
- return;
- }
-}
-
-
-/* Free a sparse array allocated with sarray_new */
-void
-sarray_free (struct sarray *array) {
-#ifdef OBJC_SPARSE3
- size_t old_max_index = (array->capacity - 1)/INDEX_CAPACITY;
- struct sindex **old_indices;
-#else
- size_t old_max_index = (array->capacity - 1)/BUCKET_SIZE;
- struct sbucket **old_buckets;
-#endif
- size_t counter = 0;
-
- assert (array->ref_count != 0); /* Freed multiple times!!! */
-
- if (--(array->ref_count) != 0) /* There exists copies of me */
- return;
-
-#ifdef OBJC_SPARSE3
- old_indices = array->indices;
-#else
- old_buckets = array->buckets;
-#endif
-
- /* Free all entries that do not point to empty_bucket. */
- for (counter = 0; counter <= old_max_index; counter++ )
- {
-#ifdef OBJC_SPARSE3
- struct sindex *idx = old_indices[counter];
- if ((idx != array->empty_index)
- && (idx->version.version == array->version.version))
- {
- int c2;
- for (c2 = 0; c2 < INDEX_SIZE; c2++)
- {
- struct sbucket *bkt = idx->buckets[c2];
- if ((bkt != array->empty_bucket)
- && (bkt->version.version == array->version.version))
- {
- sarray_free_garbage (bkt);
- nbuckets -= 1;
- }
- }
- sarray_free_garbage (idx);
- nindices -= 1;
- }
-#else /* OBJC_SPARSE2 */
- struct sbucket *bkt = old_buckets[counter];
- if ((bkt != array->empty_bucket)
- && (bkt->version.version == array->version.version))
- {
- sarray_free_garbage (bkt);
- nbuckets -= 1;
- }
-#endif
- }
-
-#ifdef OBJC_SPARSE3
- /* Free empty_index. */
- if (array->empty_index->version.version == array->version.version)
- {
- sarray_free_garbage (array->empty_index);
- nindices -= 1;
- }
-#endif
-
- /* Free empty_bucket. */
- if (array->empty_bucket->version.version == array->version.version)
- {
- sarray_free_garbage (array->empty_bucket);
- nbuckets -= 1;
- }
- idxsize -= (old_max_index + 1);
- narrays -= 1;
-
-#ifdef OBJC_SPARSE3
- /* Free bucket table. */
- sarray_free_garbage (array->indices);
-#else
- /* Free bucket table. */
- sarray_free_garbage (array->buckets);
-#endif
-
- /* If this is a copy of another array, we free it (which might just
- decrement its reference count so it will be freed when no longer
- in use). */
- if (array->is_copy_of)
- sarray_free (array->is_copy_of);
-
- /* Free array. */
- sarray_free_garbage (array);
-}
-
-/* This is a lazy copy. Only the core of the structure is actually
- copied. */
-struct sarray *
-sarray_lazy_copy (struct sarray *oarr)
-{
- struct sarray *arr;
-
-#ifdef OBJC_SPARSE3
- size_t num_indices = ((oarr->capacity - 1)/INDEX_CAPACITY) + 1;
- struct sindex **new_indices;
-#else /* OBJC_SPARSE2 */
- size_t num_indices = ((oarr->capacity - 1)/BUCKET_SIZE) + 1;
- struct sbucket **new_buckets;
-#endif
-
- /* Allocate core array. */
- arr = (struct sarray *) objc_malloc (sizeof (struct sarray)); /* !!! */
- arr->version.version = oarr->version.version + 1;
-#ifdef OBJC_SPARSE3
- arr->empty_index = oarr->empty_index;
-#endif
- arr->empty_bucket = oarr->empty_bucket;
- arr->ref_count = 1;
- oarr->ref_count += 1;
- arr->is_copy_of = oarr;
- arr->capacity = oarr->capacity;
-
-#ifdef OBJC_SPARSE3
- /* Copy bucket table. */
- new_indices = (struct sindex **)
- objc_malloc (sizeof (struct sindex *) * num_indices);
- memcpy (new_indices, oarr->indices, sizeof (struct sindex *) * num_indices);
- arr->indices = new_indices;
-#else
- /* Copy bucket table. */
- new_buckets = (struct sbucket **)
- objc_malloc (sizeof (struct sbucket *) * num_indices);
- memcpy (new_buckets, oarr->buckets, sizeof (struct sbucket *) * num_indices);
- arr->buckets = new_buckets;
-#endif
-
- idxsize += num_indices;
- narrays += 1;
-
- return arr;
-}
diff --git a/libgcobol/selector.c b/libgcobol/selector.c
deleted file mode 100644
index 0a527bd4d96f..000000000000
--- a/libgcobol/selector.c
+++ /dev/null
@@ -1,640 +0,0 @@
-/* GNU Objective C Runtime selector related functions
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc/runtime.h"
-#include "objc/thr.h"
-#include "objc-private/hash.h"
-#include "objc-private/objc-list.h"
-#include "objc-private/module-abi-8.h"
-#include "objc-private/runtime.h"
-#include "objc-private/sarray.h"
-#include "objc-private/selector.h"
-#include <stdlib.h> /* For malloc. */
-
-/* Initial selector hash table size. Value doesn't matter much. */
-#define SELECTOR_HASH_SIZE 128
-
-/* Tables mapping selector names to uid and opposite. */
-static struct sarray *__objc_selector_array = 0; /* uid -> sel !T:MUTEX */
-static struct sarray *__objc_selector_names = 0; /* uid -> name !T:MUTEX */
-static cache_ptr __objc_selector_hash = 0; /* name -> uid !T:MUTEX */
-
-/* Number of selectors stored in each of the above tables. */
-unsigned int __objc_selector_max_index = 0; /* !T:MUTEX */
-
-/* Forward-declare an internal function. */
-static SEL
-__sel_register_typed_name (const char *name, const char *types,
- struct objc_selector *orig, BOOL is_const);
-
-void __objc_init_selector_tables (void)
-{
- __objc_selector_array = sarray_new (SELECTOR_HASH_SIZE, 0);
- __objc_selector_names = sarray_new (SELECTOR_HASH_SIZE, 0);
- __objc_selector_hash
- = objc_hash_new (SELECTOR_HASH_SIZE,
- (hash_func_type) objc_hash_string,
- (compare_func_type) objc_compare_strings);
-}
-
-/* Register a bunch of selectors from the table of selectors in a
- module. 'selectors' should not be NULL. The list is terminated by
- a selectors with a NULL sel_id. The selectors are assumed to
- contain the 'name' in the sel_id field; this is replaced with the
- final selector id after they are registered. */
-void
-__objc_register_selectors_from_module (struct objc_selector *selectors)
-{
- int i;
-
- for (i = 0; selectors[i].sel_id; ++i)
- {
- const char *name, *type;
- name = (char *) selectors[i].sel_id;
- type = (char *) selectors[i].sel_types;
- /* Constructors are constant static data and we can safely store
- pointers to them in the runtime structures, so we set
- is_const == YES. */
- __sel_register_typed_name (name, type, (struct objc_selector *) &(selectors[i]),
- /* is_const */ YES);
- }
-}
-
-/* This routine is given a class and records all of the methods in its
- class structure in the record table. */
-void
-__objc_register_selectors_from_class (Class class)
-{
- struct objc_method_list * method_list;
-
- method_list = class->methods;
- while (method_list)
- {
- __objc_register_selectors_from_list (method_list);
- method_list = method_list->method_next;
- }
-}
-
-
-/* This routine is given a list of methods and records each of the
- methods in the record table. This is the routine that does the
- actual recording work.
-
- The name and type pointers in the method list must be permanent and
- immutable. */
-void
-__objc_register_selectors_from_list (struct objc_method_list *method_list)
-{
- int i = 0;
-
- objc_mutex_lock (__objc_runtime_mutex);
- while (i < method_list->method_count)
- {
- Method method = &method_list->method_list[i];
- if (method->method_name)
- {
- method->method_name
- = __sel_register_typed_name ((const char *) method->method_name,
- method->method_types, 0, YES);
- }
- i += 1;
- }
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* The same as __objc_register_selectors_from_list, but works on a
- struct objc_method_description_list* instead of a struct
- objc_method_list*. This is only used for protocols, which have
- lists of method descriptions, not methods. */
-void
-__objc_register_selectors_from_description_list
-(struct objc_method_description_list *method_list)
-{
- int i = 0;
-
- objc_mutex_lock (__objc_runtime_mutex);
- while (i < method_list->count)
- {
- struct objc_method_description *method = &method_list->list[i];
- if (method->name)
- {
- method->name
- = __sel_register_typed_name ((const char *) method->name,
- method->types, 0, YES);
- }
- i += 1;
- }
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* Register instance methods as class methods for root classes. */
-void __objc_register_instance_methods_to_class (Class class)
-{
- struct objc_method_list *method_list;
- struct objc_method_list *class_method_list;
- int max_methods_no = 16;
- struct objc_method_list *new_list;
- Method curr_method;
-
- /* Only if a root class. */
- if (class->super_class)
- return;
-
- /* Allocate a method list to hold the new class methods. */
- new_list = objc_calloc (sizeof (struct objc_method_list)
- + sizeof (struct objc_method[max_methods_no]), 1);
- method_list = class->methods;
- class_method_list = class->class_pointer->methods;
- curr_method = &new_list->method_list[0];
-
- /* Iterate through the method lists for the class. */
- while (method_list)
- {
- int i;
-
- /* Iterate through the methods from this method list. */
- for (i = 0; i < method_list->method_count; i++)
- {
- Method mth = &method_list->method_list[i];
- if (mth->method_name
- && ! search_for_method_in_list (class_method_list,
- mth->method_name))
- {
- /* This instance method isn't a class method. Add it
- into the new_list. */
- *curr_method = *mth;
-
- /* Reallocate the method list if necessary. */
- if (++new_list->method_count == max_methods_no)
- new_list =
- objc_realloc (new_list, sizeof (struct objc_method_list)
- + sizeof (struct
- objc_method[max_methods_no += 16]));
- curr_method = &new_list->method_list[new_list->method_count];
- }
- }
-
- method_list = method_list->method_next;
- }
-
- /* If we created any new class methods then attach the method list
- to the class. */
- if (new_list->method_count)
- {
- new_list =
- objc_realloc (new_list, sizeof (struct objc_method_list)
- + sizeof (struct objc_method[new_list->method_count]));
- new_list->method_next = class->class_pointer->methods;
- class->class_pointer->methods = new_list;
- }
- else
- objc_free(new_list);
-
- __objc_update_dispatch_table_for_class (class->class_pointer);
-}
-
-BOOL
-sel_isEqual (SEL s1, SEL s2)
-{
- if (s1 == 0 || s2 == 0)
- return s1 == s2;
- else
- return s1->sel_id == s2->sel_id;
-}
-
-/* Return YES iff t1 and t2 have same method types. Ignore the
- argframe layout. */
-static BOOL
-sel_types_match (const char *t1, const char *t2)
-{
- if (! t1 || ! t2)
- return NO;
- while (*t1 && *t2)
- {
- if (*t1 == '+') t1++;
- if (*t2 == '+') t2++;
- while (isdigit ((unsigned char) *t1)) t1++;
- while (isdigit ((unsigned char) *t2)) t2++;
- /* xxx Remove these next two lines when qualifiers are put in
- all selectors, not just Protocol selectors. */
- t1 = objc_skip_type_qualifiers (t1);
- t2 = objc_skip_type_qualifiers (t2);
- if (! *t1 && ! *t2)
- return YES;
- if (*t1 != *t2)
- return NO;
- t1++;
- t2++;
- }
- return NO;
-}
-
-/* Return selector representing name. */
-SEL
-sel_get_any_uid (const char *name)
-{
- struct objc_list *l;
- sidx i;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- i = (sidx) objc_hash_value_for_key (__objc_selector_hash, name);
- if (soffset_decode (i) == 0)
- {
- objc_mutex_unlock (__objc_runtime_mutex);
- return 0;
- }
-
- l = (struct objc_list *) sarray_get_safe (__objc_selector_array, i);
- objc_mutex_unlock (__objc_runtime_mutex);
-
- if (l == 0)
- return 0;
-
- return (SEL) l->head;
-}
-
-SEL
-sel_getTypedSelector (const char *name)
-{
- sidx i;
-
- if (name == NULL)
- return NULL;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Look for a typed selector. */
- i = (sidx) objc_hash_value_for_key (__objc_selector_hash, name);
- if (i != 0)
- {
- struct objc_list *l;
- SEL returnValue = NULL;
-
- for (l = (struct objc_list *) sarray_get_safe (__objc_selector_array, i);
- l; l = l->tail)
- {
- SEL s = (SEL) l->head;
- if (s->sel_types)
- {
- if (returnValue == NULL)
- {
- /* First typed selector that we find. Keep it in
- returnValue, but keep checking as we want to
- detect conflicts. */
- returnValue = s;
- }
- else
- {
- /* We had already found a typed selectors, so we
- have multiple ones. Double-check that they have
- different types, just in case for some reason we
- got duplicates with the same types. If so, it's
- OK, we'll ignore the duplicate. */
- if (returnValue->sel_types == s->sel_types)
- continue;
- else if (sel_types_match (returnValue->sel_types, s->sel_types))
- continue;
- else
- {
- /* The types of the two selectors are different;
- it's a conflict. Too bad. Return NULL. */
- objc_mutex_unlock (__objc_runtime_mutex);
- return NULL;
- }
- }
- }
- }
-
- if (returnValue != NULL)
- {
- objc_mutex_unlock (__objc_runtime_mutex);
- return returnValue;
- }
- }
-
- /* No typed selector found. Return NULL. */
- objc_mutex_unlock (__objc_runtime_mutex);
- return 0;
-}
-
-SEL *
-sel_copyTypedSelectorList (const char *name, unsigned int *numberOfReturnedSelectors)
-{
- unsigned int count = 0;
- SEL *returnValue = NULL;
- sidx i;
-
- if (name == NULL)
- {
- if (numberOfReturnedSelectors)
- *numberOfReturnedSelectors = 0;
- return NULL;
- }
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Count how many selectors we have. */
- i = (sidx) objc_hash_value_for_key (__objc_selector_hash, name);
- if (i != 0)
- {
- struct objc_list *selector_list = NULL;
- selector_list = (struct objc_list *) sarray_get_safe (__objc_selector_array, i);
-
- /* Count how many selectors we have. */
- {
- struct objc_list *l;
- for (l = selector_list; l; l = l->tail)
- count++;
- }
-
- if (count != 0)
- {
- /* Allocate enough memory to hold them. */
- returnValue = (SEL *)(malloc (sizeof (SEL) * (count + 1)));
-
- /* Copy the selectors. */
- {
- unsigned int j;
- for (j = 0; j < count; j++)
- {
- returnValue[j] = (SEL)(selector_list->head);
- selector_list = selector_list->tail;
- }
- returnValue[j] = NULL;
- }
- }
- }
-
- objc_mutex_unlock (__objc_runtime_mutex);
-
- if (numberOfReturnedSelectors)
- *numberOfReturnedSelectors = count;
-
- return returnValue;
-}
-
-/* Get the name of a selector. If the selector is unknown, the empty
- string "" is returned. */
-const char *sel_getName (SEL selector)
-{
- const char *ret;
-
- if (selector == NULL)
- return "<null selector>";
-
- objc_mutex_lock (__objc_runtime_mutex);
- if ((soffset_decode ((sidx)selector->sel_id) > 0)
- && (soffset_decode ((sidx)selector->sel_id) <= __objc_selector_max_index))
- ret = sarray_get_safe (__objc_selector_names, (sidx) selector->sel_id);
- else
- ret = 0;
- objc_mutex_unlock (__objc_runtime_mutex);
- return ret;
-}
-
-BOOL
-sel_is_mapped (SEL selector)
-{
- unsigned int idx = soffset_decode ((sidx)selector->sel_id);
- return ((idx > 0) && (idx <= __objc_selector_max_index));
-}
-
-const char *sel_getTypeEncoding (SEL selector)
-{
- if (selector)
- return selector->sel_types;
- else
- return 0;
-}
-
-/* The uninstalled dispatch table. */
-extern struct sarray *__objc_uninstalled_dtable;
-
-/* __sel_register_typed_name allocates lots of struct objc_selector:s
- of 8 (16, if pointers are 64 bits) bytes at startup. To reduce the
- number of malloc calls and memory lost to malloc overhead, we
- allocate objc_selector:s in blocks here. This is only called from
- __sel_register_typed_name, and __sel_register_typed_name may only
- be called when __objc_runtime_mutex is locked.
-
- Note that the objc_selector:s allocated from
- __sel_register_typed_name are never freed.
-
- 62 because 62 * sizeof (struct objc_selector) = 496 (992). This
- should let malloc add some overhead and use a nice, round 512
- (1024) byte chunk. */
-#define SELECTOR_POOL_SIZE 62
-static struct objc_selector *selector_pool;
-static int selector_pool_left;
-
-static struct objc_selector *
-pool_alloc_selector(void)
-{
- if (!selector_pool_left)
- {
- selector_pool = objc_malloc (sizeof (struct objc_selector)
- * SELECTOR_POOL_SIZE);
- selector_pool_left = SELECTOR_POOL_SIZE;
- }
- return &selector_pool[--selector_pool_left];
-}
-
-/* Store the passed selector name in the selector record and return
- its selector value (value returned by sel_get_uid). Assume that
- the calling function has locked down __objc_runtime_mutex. The
- 'is_const' parameter tells us if the name and types parameters are
- really constant or not. If YES then they are constant and we can
- just store the pointers. If NO then we need to copy name and types
- because the pointers may disappear later on. If the 'orig'
- parameter is not NULL, then we are registering a selector from a
- module, and 'orig' is that selector. In this case, we can put the
- selector in the tables if needed, and orig->sel_id is updated with
- the selector ID of the registered selector, and 'orig' is
- returned. */
-static SEL
-__sel_register_typed_name (const char *name, const char *types,
- struct objc_selector *orig, BOOL is_const)
-{
- struct objc_selector *j;
- sidx i;
- struct objc_list *l;
-
- i = (sidx) objc_hash_value_for_key (__objc_selector_hash, name);
- if (soffset_decode (i) != 0)
- {
- /* There are already selectors with that name. Examine them to
- see if the one we're registering already exists. */
- for (l = (struct objc_list *)sarray_get_safe (__objc_selector_array, i);
- l; l = l->tail)
- {
- SEL s = (SEL)l->head;
- if (types == 0 || s->sel_types == 0)
- {
- if (s->sel_types == types)
- {
- if (orig)
- {
- orig->sel_id = (void *)i;
- return orig;
- }
- else
- return s;
- }
- }
- else if (sel_types_match (s->sel_types, types))
- {
- if (orig)
- {
- orig->sel_id = (void *)i;
- return orig;
- }
- else
- return s;
- }
- }
- /* A selector with this specific name/type combination does not
- exist yet. We need to register it. */
- if (orig)
- j = orig;
- else
- j = pool_alloc_selector ();
-
- j->sel_id = (void *)i;
- /* Can we use the pointer or must we copy types ? Don't copy if
- NULL. */
- if ((is_const) || (types == 0))
- j->sel_types = types;
- else
- {
- j->sel_types = (char *)objc_malloc (strlen (types) + 1);
- strcpy ((char *)j->sel_types, types);
- }
- l = (struct objc_list *)sarray_get_safe (__objc_selector_array, i);
- }
- else
- {
- /* There are no other selectors with this name registered in the
- runtime tables. */
- const char *new_name;
-
- /* Determine i. */
- __objc_selector_max_index += 1;
- i = soffset_encode (__objc_selector_max_index);
-
- /* Prepare the selector. */
- if (orig)
- j = orig;
- else
- j = pool_alloc_selector ();
-
- j->sel_id = (void *)i;
- /* Can we use the pointer or must we copy types ? Don't copy if
- NULL. */
- if (is_const || (types == 0))
- j->sel_types = types;
- else
- {
- j->sel_types = (char *)objc_malloc (strlen (types) + 1);
- strcpy ((char *)j->sel_types, types);
- }
-
- /* Since this is the first selector with this name, we need to
- register the correspondence between 'i' (the sel_id) and
- 'name' (the actual string) in __objc_selector_names and
- __objc_selector_hash. */
-
- /* Can we use the pointer or must we copy name ? Don't copy if
- NULL. (FIXME: Can the name really be NULL here ?) */
- if (is_const || (name == 0))
- new_name = name;
- else
- {
- new_name = (char *)objc_malloc (strlen (name) + 1);
- strcpy ((char *)new_name, name);
- }
-
- /* This maps the sel_id to the name. */
- sarray_at_put_safe (__objc_selector_names, i, (void *)new_name);
-
- /* This maps the name to the sel_id. */
- objc_hash_add (&__objc_selector_hash, (void *)new_name, (void *)i);
-
- l = 0;
- }
-
- DEBUG_PRINTF ("Record selector %s[%s] as: %ld\n", name, types,
- (long)soffset_decode (i));
-
- /* Now add the selector to the list of selectors with that id. */
- l = list_cons ((void *)j, l);
- sarray_at_put_safe (__objc_selector_array, i, (void *)l);
-
- sarray_realloc (__objc_uninstalled_dtable, __objc_selector_max_index + 1);
-
- return (SEL)j;
-}
-
-SEL
-sel_registerName (const char *name)
-{
- SEL ret;
-
- if (name == NULL)
- return NULL;
-
- objc_mutex_lock (__objc_runtime_mutex);
- /* Assume that name is not constant static memory and needs to be
- copied before put into a runtime structure. is_const == NO. */
- ret = __sel_register_typed_name (name, 0, 0, NO);
- objc_mutex_unlock (__objc_runtime_mutex);
-
- return ret;
-}
-
-SEL
-sel_registerTypedName (const char *name, const char *type)
-{
- SEL ret;
-
- if (name == NULL)
- return NULL;
-
- objc_mutex_lock (__objc_runtime_mutex);
- /* Assume that name and type are not constant static memory and need
- to be copied before put into a runtime structure. is_const ==
- NO. */
- ret = __sel_register_typed_name (name, type, 0, NO);
- objc_mutex_unlock (__objc_runtime_mutex);
-
- return ret;
-}
-
-/* Return the selector representing name. */
-SEL
-sel_getUid (const char *name)
-{
- return sel_registerTypedName (name, 0);
-}
diff --git a/libgcobol/sendmsg.c b/libgcobol/sendmsg.c
deleted file mode 100644
index a7f949f524e3..000000000000
--- a/libgcobol/sendmsg.c
+++ /dev/null
@@ -1,1164 +0,0 @@
-/* GNU Objective C Runtime message lookup
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Kresten Krab Thorup
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-/* Uncommented the following line to enable debug logging. Use this
- only while debugging the runtime. */
-/* #define DEBUG 1 */
-
-/* FIXME: This should be using libffi instead of __builtin_apply
- and friends. */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-#include "tconfig.h"
-#include "coretypes.h"
-#include "objc/runtime.h"
-#include "objc/message.h" /* For objc_msg_lookup(), objc_msg_lookup_super(). */
-#include "objc/thr.h"
-#include "objc-private/module-abi-8.h"
-#include "objc-private/runtime.h"
-#include "objc-private/hash.h"
-#include "objc-private/sarray.h"
-#include "objc-private/selector.h" /* For sel_is_mapped() */
-#include "runtime-info.h"
-#include <assert.h> /* For assert */
-#include <string.h> /* For strlen */
-
-#define INVISIBLE_STRUCT_RETURN 1
-
-/* The uninstalled dispatch table. If a class' dispatch table points
- to __objc_uninstalled_dtable then that means it needs its dispatch
- table to be installed. */
-struct sarray *__objc_uninstalled_dtable = 0; /* !T:MUTEX */
-
-/* Two hooks for method forwarding. If either is set, it is invoked to
- * return a function that performs the real forwarding. If both are
- * set, the result of __objc_msg_forward2 will be preferred over that
- * of __objc_msg_forward. If both return NULL or are unset, the
- * libgcc based functions (__builtin_apply and friends) are used. */
-IMP (*__objc_msg_forward) (SEL) = NULL;
-IMP (*__objc_msg_forward2) (id, SEL) = NULL;
-
-/* Send +initialize to class. */
-static void __objc_send_initialize (Class);
-
-/* Forward declare some functions */
-static void __objc_install_dtable_for_class (Class cls);
-static void __objc_prepare_dtable_for_class (Class cls);
-static void __objc_install_prepared_dtable_for_class (Class cls);
-
-static struct sarray *__objc_prepared_dtable_for_class (Class cls);
-static IMP __objc_get_prepared_imp (Class cls,SEL sel);
-
-
-/* Various forwarding functions that are used based upon the
- return type for the selector.
- __objc_block_forward for structures.
- __objc_double_forward for floats/doubles.
- __objc_word_forward for pointers or types that fit in registers. */
-static double __objc_double_forward (id, SEL, ...);
-static id __objc_word_forward (id, SEL, ...);
-typedef struct { id many[8]; } __big;
-#if INVISIBLE_STRUCT_RETURN
-static __big
-#else
-static id
-#endif
-__objc_block_forward (id, SEL, ...);
-static struct objc_method * search_for_method_in_hierarchy (Class class, SEL sel);
-struct objc_method * search_for_method_in_list (struct objc_method_list * list, SEL op);
-id nil_method (id, SEL);
-
-/* Make sure this inline function is exported regardless of GNU89 or C99
- inlining semantics as it is part of the libobjc ABI. */
-extern IMP __objc_get_forward_imp (id, SEL);
-
-/* Given a selector, return the proper forwarding implementation. */
-inline
-IMP
-__objc_get_forward_imp (id rcv, SEL sel)
-{
- /* If a custom forwarding hook was registered, try getting a
- forwarding function from it. There are two forward routine hooks,
- one that takes the receiver as an argument and one that does
- not. */
- if (__objc_msg_forward2)
- {
- IMP result;
- if ((result = __objc_msg_forward2 (rcv, sel)) != NULL)
- return result;
- }
- if (__objc_msg_forward)
- {
- IMP result;
- if ((result = __objc_msg_forward (sel)) != NULL)
- return result;
- }
-
- /* In all other cases, use the default forwarding functions built
- using __builtin_apply and friends. */
- {
- const char *t = sel->sel_types;
-
- if (t && (*t == '[' || *t == '(' || *t == '{')
-#ifdef OBJC_MAX_STRUCT_BY_VALUE
- && objc_sizeof_type (t) > OBJC_MAX_STRUCT_BY_VALUE
-#endif
- )
- return (IMP)__objc_block_forward;
- else if (t && (*t == 'f' || *t == 'd'))
- return (IMP)__objc_double_forward;
- else
- return (IMP)__objc_word_forward;
- }
-}
-
-/* Selectors for +resolveClassMethod: and +resolveInstanceMethod:.
- These are set up at startup. */
-static SEL selector_resolveClassMethod = NULL;
-static SEL selector_resolveInstanceMethod = NULL;
-
-/* Internal routines use to resolve a class method using
- +resolveClassMethod:. 'class' is always a non-Nil class (*not* a
- meta-class), and 'sel' is the selector that we are trying to
- resolve. This must be called when class is not Nil, and the
- dispatch table for class methods has already been installed.
-
- This routine tries to call +resolveClassMethod: to give an
- opportunity to resolve the method. If +resolveClassMethod: returns
- YES, it tries looking up the method again, and if found, it returns
- it. Else, it returns NULL. */
-static inline
-IMP
-__objc_resolve_class_method (Class class, SEL sel)
-{
- /* We need to lookup +resolveClassMethod:. */
- BOOL (*resolveMethodIMP) (id, SEL, SEL);
-
- /* The dispatch table for class methods is already installed and we
- don't want any forwarding to happen when looking up this method,
- so we just look it up directly. Note that if 'sel' is precisely
- +resolveClassMethod:, this would look it up yet again and find
- nothing. That's no problem and there's no recursion. */
- resolveMethodIMP = (BOOL (*) (id, SEL, SEL))sarray_get_safe
- (class->class_pointer->dtable, (size_t) selector_resolveClassMethod->sel_id);
-
- if (resolveMethodIMP && resolveMethodIMP ((id)class, selector_resolveClassMethod, sel))
- {
- /* +resolveClassMethod: returned YES. Look the method up again.
- We already know the dtable is installed. */
-
- /* TODO: There is the case where +resolveClassMethod: is buggy
- and returned YES without actually adding the method. We
- could maybe print an error message. */
- return sarray_get_safe (class->class_pointer->dtable, (size_t) sel->sel_id);
- }
-
- return NULL;
-}
-
-/* Internal routines use to resolve a instance method using
- +resolveInstanceMethod:. 'class' is always a non-Nil class, and
- 'sel' is the selector that we are trying to resolve. This must be
- called when class is not Nil, and the dispatch table for instance
- methods has already been installed.
-
- This routine tries to call +resolveInstanceMethod: to give an
- opportunity to resolve the method. If +resolveInstanceMethod:
- returns YES, it tries looking up the method again, and if found, it
- returns it. Else, it returns NULL. */
-static inline
-IMP
-__objc_resolve_instance_method (Class class, SEL sel)
-{
- /* We need to lookup +resolveInstanceMethod:. */
- BOOL (*resolveMethodIMP) (id, SEL, SEL);
-
- /* The dispatch table for class methods may not be already installed
- so we have to install it if needed. */
- resolveMethodIMP = sarray_get_safe (class->class_pointer->dtable,
- (size_t) selector_resolveInstanceMethod->sel_id);
- if (resolveMethodIMP == 0)
- {
- /* Try again after installing the dtable. */
- if (class->class_pointer->dtable == __objc_uninstalled_dtable)
- {
- objc_mutex_lock (__objc_runtime_mutex);
- if (class->class_pointer->dtable == __objc_uninstalled_dtable)
- __objc_install_dtable_for_class (class->class_pointer);
- objc_mutex_unlock (__objc_runtime_mutex);
- }
- resolveMethodIMP = sarray_get_safe (class->class_pointer->dtable,
- (size_t) selector_resolveInstanceMethod->sel_id);
- }
-
- if (resolveMethodIMP && resolveMethodIMP ((id)class, selector_resolveInstanceMethod, sel))
- {
- /* +resolveInstanceMethod: returned YES. Look the method up
- again. We already know the dtable is installed. */
-
- /* TODO: There is the case where +resolveInstanceMethod: is
- buggy and returned YES without actually adding the method.
- We could maybe print an error message. */
- return sarray_get_safe (class->dtable, (size_t) sel->sel_id);
- }
-
- return NULL;
-}
-
-/* Given a CLASS and selector, return the implementation corresponding
- to the method of the selector.
-
- If CLASS is a class, the instance method is returned.
- If CLASS is a meta class, the class method is returned.
-
- Since this requires the dispatch table to be installed, this function
- will implicitly invoke +initialize for CLASS if it hasn't been
- invoked yet. This also insures that +initialize has been invoked
- when the returned implementation is called directly.
-
- The forwarding hooks require the receiver as an argument (if they are to
- perform dynamic lookup in proxy objects etc), so this function has a
- receiver argument to be used with those hooks. */
-static inline
-IMP
-get_implementation (id receiver, Class class, SEL sel)
-{
- void *res;
-
- if (class->dtable == __objc_uninstalled_dtable)
- {
- /* The dispatch table needs to be installed. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Double-checked locking pattern: Check
- __objc_uninstalled_dtable again in case another thread
- installed the dtable while we were waiting for the lock to be
- released. */
- if (class->dtable == __objc_uninstalled_dtable)
- __objc_install_dtable_for_class (class);
-
- /* If the dispatch table is not yet installed, we are still in
- the process of executing +initialize. But the implementation
- pointer should be available in the prepared ispatch table if
- it exists at all. */
- if (class->dtable == __objc_uninstalled_dtable)
- {
- assert (__objc_prepared_dtable_for_class (class) != 0);
- res = __objc_get_prepared_imp (class, sel);
- }
- else
- res = 0;
-
- objc_mutex_unlock (__objc_runtime_mutex);
- /* Call ourselves with the installed dispatch table and get the
- real method. */
- if (!res)
- res = get_implementation (receiver, class, sel);
- }
- else
- {
- /* The dispatch table has been installed. */
- res = sarray_get_safe (class->dtable, (size_t) sel->sel_id);
- if (res == 0)
- {
- /* The dispatch table has been installed, and the method is
- not in the dispatch table. So the method just doesn't
- exist for the class. */
-
- /* Try going through the +resolveClassMethod: or
- +resolveInstanceMethod: process. */
- if (CLS_ISMETA (class))
- {
- /* We have the meta class, but we need to invoke the
- +resolveClassMethod: method on the class. So, we
- need to obtain the class from the meta class, which
- we do using the fact that both the class and the
- meta-class have the same name. */
- Class realClass = objc_lookUpClass (class->name);
- if (realClass)
- res = __objc_resolve_class_method (realClass, sel);
- }
- else
- res = __objc_resolve_instance_method (class, sel);
-
- if (res == 0)
- res = __objc_get_forward_imp (receiver, sel);
- }
- }
- return res;
-}
-
-/* Make sure this inline function is exported regardless of GNU89 or C99
- inlining semantics as it is part of the libobjc ABI. */
-extern IMP get_imp (Class, SEL);
-
-inline
-IMP
-get_imp (Class class, SEL sel)
-{
- /* In a vanilla implementation we would first check if the dispatch
- table is installed. Here instead, to get more speed in the
- standard case (that the dispatch table is installed) we first try
- to get the imp using brute force. Only if that fails, we do what
- we should have been doing from the very beginning, that is, check
- if the dispatch table needs to be installed, install it if it's
- not installed, and retrieve the imp from the table if it's
- installed. */
- void *res = sarray_get_safe (class->dtable, (size_t) sel->sel_id);
- if (res == 0)
- {
- res = get_implementation(nil, class, sel);
- }
- return res;
-}
-
-/* The new name of get_imp(). */
-IMP
-class_getMethodImplementation (Class class_, SEL selector)
-{
- if (class_ == Nil || selector == NULL)
- return NULL;
-
- /* get_imp is inlined, so we're good. */
- return get_imp (class_, selector);
-}
-
-/* Given a method, return its implementation. This has been replaced
- by method_getImplementation() in the modern API. */
-IMP
-method_get_imp (struct objc_method * method)
-{
- return (method != (struct objc_method *)0) ? method->method_imp : (IMP)0;
-}
-
-/* Query if an object can respond to a selector, returns YES if the
- object implements the selector otherwise NO. Does not check if the
- method can be forwarded. Since this requires the dispatch table to
- installed, this function will implicitly invoke +initialize for the
- class of OBJECT if it hasn't been invoked yet. */
-inline
-BOOL
-__objc_responds_to (id object, SEL sel)
-{
- void *res;
- struct sarray *dtable;
-
- /* Install dispatch table if need be */
- dtable = object->class_pointer->dtable;
- if (dtable == __objc_uninstalled_dtable)
- {
- objc_mutex_lock (__objc_runtime_mutex);
- if (object->class_pointer->dtable == __objc_uninstalled_dtable)
- __objc_install_dtable_for_class (object->class_pointer);
-
- /* If the dispatch table is not yet installed, we are still in
- the process of executing +initialize. Yet the dispatch table
- should be available. */
- if (object->class_pointer->dtable == __objc_uninstalled_dtable)
- {
- dtable = __objc_prepared_dtable_for_class (object->class_pointer);
- assert (dtable);
- }
- else
- dtable = object->class_pointer->dtable;
-
- objc_mutex_unlock (__objc_runtime_mutex);
- }
-
- /* Get the method from the dispatch table. */
- res = sarray_get_safe (dtable, (size_t) sel->sel_id);
- return (res != 0) ? YES : NO;
-}
-
-BOOL
-class_respondsToSelector (Class class_, SEL selector)
-{
- struct sarray *dtable;
- void *res;
-
- if (class_ == Nil || selector == NULL)
- return NO;
-
- /* Install dispatch table if need be. */
- dtable = class_->dtable;
- if (dtable == __objc_uninstalled_dtable)
- {
- objc_mutex_lock (__objc_runtime_mutex);
- if (class_->dtable == __objc_uninstalled_dtable)
- __objc_install_dtable_for_class (class_);
-
- /* If the dispatch table is not yet installed,
- we are still in the process of executing +initialize.
- Yet the dispatch table should be available. */
- if (class_->dtable == __objc_uninstalled_dtable)
- {
- dtable = __objc_prepared_dtable_for_class (class_);
- assert (dtable);
- }
- else
- dtable = class_->dtable;
-
- objc_mutex_unlock (__objc_runtime_mutex);
- }
-
- /* Get the method from the dispatch table. */
- res = sarray_get_safe (dtable, (size_t) selector->sel_id);
- return (res != 0) ? YES : NO;
-}
-
-/* This is the lookup function. All entries in the table are either a
- valid method *or* zero. If zero then either the dispatch table
- needs to be installed or it doesn't exist and forwarding is
- attempted. */
-IMP
-objc_msg_lookup (id receiver, SEL op)
-{
- IMP result;
- if (receiver)
- {
- /* First try a quick lookup assuming the dispatch table exists. */
- result = sarray_get_safe (receiver->class_pointer->dtable,
- (sidx)op->sel_id);
- if (result == 0)
- {
- /* Not found ... call get_implementation () to install the
- dispatch table and call +initialize as required,
- providing the method implementation or a forwarding
- function. */
- result = get_implementation (receiver, receiver->class_pointer, op);
- }
- return result;
- }
- else
- return (IMP)nil_method;
-}
-
-IMP
-objc_msg_lookup_super (struct objc_super *super, SEL sel)
-{
- if (super->self)
- return get_imp (super->super_class, sel);
- else
- return (IMP)nil_method;
-}
-
-void
-__objc_init_dispatch_tables ()
-{
- __objc_uninstalled_dtable = sarray_new (200, 0);
-
- /* TODO: It would be cool to register typed selectors here. */
- selector_resolveClassMethod = sel_registerName ("resolveClassMethod:");
- selector_resolveInstanceMethod = sel_registerName ("resolveInstanceMethod:");
-}
-
-
-/* Install dummy table for class which causes the first message to
- that class (or instances hereof) to be initialized properly. */
-void
-__objc_install_premature_dtable (Class class)
-{
- assert (__objc_uninstalled_dtable);
- class->dtable = __objc_uninstalled_dtable;
-}
-
-/* Send +initialize to class if not already done. */
-static void
-__objc_send_initialize (Class class)
-{
- /* This *must* be a class object. */
- assert (CLS_ISCLASS (class));
- assert (! CLS_ISMETA (class));
-
- /* class_add_method_list/__objc_update_dispatch_table_for_class may
- have reset the dispatch table. The canonical way to insure that
- we send +initialize just once, is this flag. */
- if (! CLS_ISINITIALIZED (class))
- {
- DEBUG_PRINTF ("+initialize: need to initialize class '%s'\n", class->name);
- CLS_SETINITIALIZED (class);
- CLS_SETINITIALIZED (class->class_pointer);
-
- /* Create the garbage collector type memory description. */
- __objc_generate_gc_type_description (class);
-
- if (class->super_class)
- __objc_send_initialize (class->super_class);
-
- {
- SEL op = sel_registerName ("initialize");
- struct objc_method *method = search_for_method_in_hierarchy (class->class_pointer,
- op);
-
- if (method)
- {
- DEBUG_PRINTF (" begin of [%s +initialize]\n", class->name);
- (*method->method_imp) ((id)class, op);
- DEBUG_PRINTF (" end of [%s +initialize]\n", class->name);
- }
-#ifdef DEBUG
- else
- {
- DEBUG_PRINTF (" class '%s' has no +initialize method\n", class->name);
- }
-#endif
- }
- }
-}
-
-/* Walk on the methods list of class and install the methods in the
- reverse order of the lists. Since methods added by categories are
- before the methods of class in the methods list, this allows
- categories to substitute methods declared in class. However if
- more than one category replaces the same method nothing is
- guaranteed about what method will be used. Assumes that
- __objc_runtime_mutex is locked down. */
-static void
-__objc_install_methods_in_dtable (struct sarray *dtable, struct objc_method_list * method_list)
-{
- int i;
-
- if (! method_list)
- return;
-
- if (method_list->method_next)
- __objc_install_methods_in_dtable (dtable, method_list->method_next);
-
- for (i = 0; i < method_list->method_count; i++)
- {
- struct objc_method * method = &(method_list->method_list[i]);
- sarray_at_put_safe (dtable,
- (sidx) method->method_name->sel_id,
- method->method_imp);
- }
-}
-
-void
-__objc_update_dispatch_table_for_class (Class class)
-{
- Class next;
- struct sarray *arr;
-
- DEBUG_PRINTF (" _objc_update_dtable_for_class (%s)\n", class->name);
-
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Not yet installed -- skip it unless in +initialize. */
- if (class->dtable == __objc_uninstalled_dtable)
- {
- if (__objc_prepared_dtable_for_class (class))
- {
- /* There is a prepared table so we must be initialising this
- class ... we must re-do the table preparation. */
- __objc_prepare_dtable_for_class (class);
- }
- objc_mutex_unlock (__objc_runtime_mutex);
- return;
- }
-
- arr = class->dtable;
- __objc_install_premature_dtable (class); /* someone might require it... */
- sarray_free (arr); /* release memory */
-
- /* Could have been lazy... */
- __objc_install_dtable_for_class (class);
-
- if (class->subclass_list) /* Traverse subclasses. */
- for (next = class->subclass_list; next; next = next->sibling_class)
- __objc_update_dispatch_table_for_class (next);
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* This function adds a method list to a class. This function is
- typically called by another function specific to the run-time. As
- such this function does not worry about thread safe issues.
-
- This one is only called for categories. Class objects have their
- methods installed right away, and their selectors are made into
- SEL's by the function __objc_register_selectors_from_class. */
-void
-class_add_method_list (Class class, struct objc_method_list * list)
-{
- /* Passing of a linked list is not allowed. Do multiple calls. */
- assert (! list->method_next);
-
- __objc_register_selectors_from_list(list);
-
- /* Add the methods to the class's method list. */
- list->method_next = class->methods;
- class->methods = list;
-
- /* Update the dispatch table of class. */
- __objc_update_dispatch_table_for_class (class);
-}
-
-struct objc_method *
-class_getInstanceMethod (Class class_, SEL selector)
-{
- struct objc_method *m;
-
- if (class_ == Nil || selector == NULL)
- return NULL;
-
- m = search_for_method_in_hierarchy (class_, selector);
- if (m)
- return m;
-
- /* Try going through +resolveInstanceMethod:, and do the search
- again if successful. */
- if (__objc_resolve_instance_method (class_, selector))
- return search_for_method_in_hierarchy (class_, selector);
-
- return NULL;
-}
-
-struct objc_method *
-class_getClassMethod (Class class_, SEL selector)
-{
- struct objc_method *m;
-
- if (class_ == Nil || selector == NULL)
- return NULL;
-
- m = search_for_method_in_hierarchy (class_->class_pointer,
- selector);
- if (m)
- return m;
-
- /* Try going through +resolveClassMethod:, and do the search again
- if successful. */
- if (__objc_resolve_class_method (class_, selector))
- return search_for_method_in_hierarchy (class_->class_pointer,
- selector);
-
- return NULL;
-}
-
-BOOL
-class_addMethod (Class class_, SEL selector, IMP implementation,
- const char *method_types)
-{
- struct objc_method_list *method_list;
- struct objc_method *method;
- const char *method_name;
-
- if (class_ == Nil || selector == NULL || implementation == NULL
- || method_types == NULL || (strcmp (method_types, "") == 0))
- return NO;
-
- method_name = sel_getName (selector);
- if (method_name == NULL)
- return NO;
-
- /* If the method already exists in the class, return NO. It is fine
- if the method already exists in the superclass; in that case, we
- are overriding it. */
- if (CLS_IS_IN_CONSTRUCTION (class_))
- {
- /* The class only contains a list of methods; they have not been
- registered yet, ie, the method_name of each of them is still
- a string, not a selector. Iterate manually over them to
- check if we have already added the method. */
- struct objc_method_list * method_list = class_->methods;
- while (method_list)
- {
- int i;
-
- /* Search the method list. */
- for (i = 0; i < method_list->method_count; ++i)
- {
- struct objc_method * method = &method_list->method_list[i];
-
- if (method->method_name
- && strcmp ((char *)method->method_name, method_name) == 0)
- return NO;
- }
-
- /* The method wasn't found. Follow the link to the next list of
- methods. */
- method_list = method_list->method_next;
- }
- /* The method wasn't found. It's a new one. Go ahead and add
- it. */
- }
- else
- {
- /* Do the standard lookup. This assumes the selectors are
- mapped. */
- if (search_for_method_in_list (class_->methods, selector))
- return NO;
- }
-
- method_list = (struct objc_method_list *)objc_calloc (1, sizeof (struct objc_method_list));
- method_list->method_count = 1;
-
- method = &(method_list->method_list[0]);
- method->method_name = objc_malloc (strlen (method_name) + 1);
- strcpy ((char *)method->method_name, method_name);
-
- method->method_types = objc_malloc (strlen (method_types) + 1);
- strcpy ((char *)method->method_types, method_types);
-
- method->method_imp = implementation;
-
- if (CLS_IS_IN_CONSTRUCTION (class_))
- {
- /* We only need to add the method to the list. It will be
- registered with the runtime when the class pair is registered
- (if ever). */
- method_list->method_next = class_->methods;
- class_->methods = method_list;
- }
- else
- {
- /* Add the method to a live class. */
- objc_mutex_lock (__objc_runtime_mutex);
- class_add_method_list (class_, method_list);
- objc_mutex_unlock (__objc_runtime_mutex);
- }
-
- return YES;
-}
-
-IMP
-class_replaceMethod (Class class_, SEL selector, IMP implementation,
- const char *method_types)
-{
- struct objc_method * method;
-
- if (class_ == Nil || selector == NULL || implementation == NULL
- || method_types == NULL)
- return NULL;
-
- method = search_for_method_in_hierarchy (class_, selector);
-
- if (method)
- {
- return method_setImplementation (method, implementation);
- }
- else
- {
- class_addMethod (class_, selector, implementation, method_types);
- return NULL;
- }
-}
-
-/* Search for a method starting from the current class up its
- hierarchy. Return a pointer to the method's method structure if
- found. NULL otherwise. */
-static struct objc_method *
-search_for_method_in_hierarchy (Class cls, SEL sel)
-{
- struct objc_method * method = NULL;
- Class class;
-
- if (! sel_is_mapped (sel))
- return NULL;
-
- /* Scan the method list of the class. If the method isn't found in
- the list then step to its super class. */
- for (class = cls; ((! method) && class); class = class->super_class)
- method = search_for_method_in_list (class->methods, sel);
-
- return method;
-}
-
-
-
-/* Given a linked list of method and a method's name. Search for the
- named method's method structure. Return a pointer to the method's
- method structure if found. NULL otherwise. */
-struct objc_method *
-search_for_method_in_list (struct objc_method_list * list, SEL op)
-{
- struct objc_method_list * method_list = list;
-
- if (! sel_is_mapped (op))
- return NULL;
-
- /* If not found then we'll search the list. */
- while (method_list)
- {
- int i;
-
- /* Search the method list. */
- for (i = 0; i < method_list->method_count; ++i)
- {
- struct objc_method * method = &method_list->method_list[i];
-
- if (method->method_name)
- if (method->method_name->sel_id == op->sel_id)
- return method;
- }
-
- /* The method wasn't found. Follow the link to the next list of
- methods. */
- method_list = method_list->method_next;
- }
-
- return NULL;
-}
-
-typedef void * retval_t;
-typedef void * arglist_t;
-
-static retval_t __objc_forward (id object, SEL sel, arglist_t args);
-
-/* Forwarding pointers/integers through the normal registers. */
-static id
-__objc_word_forward (id rcv, SEL op, ...)
-{
- void *args, *res;
-
- args = __builtin_apply_args ();
- res = __objc_forward (rcv, op, args);
- if (res)
- __builtin_return (res);
- else
- return res;
-}
-
-/* Specific routine for forwarding floats/double because of
- architectural differences on some processors. i386s for example
- which uses a floating point stack versus general registers for
- floating point numbers. This forward routine makes sure that GCC
- restores the proper return values. */
-static double
-__objc_double_forward (id rcv, SEL op, ...)
-{
- void *args, *res;
-
- args = __builtin_apply_args ();
- res = __objc_forward (rcv, op, args);
- __builtin_return (res);
-}
-
-#if INVISIBLE_STRUCT_RETURN
-static __big
-#else
-static id
-#endif
-__objc_block_forward (id rcv, SEL op, ...)
-{
- void *args, *res;
-
- args = __builtin_apply_args ();
- res = __objc_forward (rcv, op, args);
- if (res)
- __builtin_return (res);
- else
-#if INVISIBLE_STRUCT_RETURN
- return (__big) {{0, 0, 0, 0, 0, 0, 0, 0}};
-#else
- return nil;
-#endif
-}
-
-
-/* This function is called for methods which are not implemented,
- unless a custom forwarding routine has been installed. Please note
- that most serious users of libobjc (eg, GNUstep base) do install
- their own forwarding routines, and hence this is never actually
- used. But, if no custom forwarding routine is installed, this is
- called when a selector is not recognized. */
-static retval_t
-__objc_forward (id object, SEL sel, arglist_t args)
-{
- IMP imp;
- static SEL frwd_sel = 0; /* !T:SAFE2 */
- SEL err_sel;
-
- /* First try if the object understands forward::. */
- if (! frwd_sel)
- frwd_sel = sel_get_any_uid ("forward::");
-
- if (__objc_responds_to (object, frwd_sel))
- {
- imp = get_implementation (object, object->class_pointer, frwd_sel);
- return (*imp) (object, frwd_sel, sel, args);
- }
-
- /* If the object recognizes the doesNotRecognize: method then we're
- going to send it. */
- err_sel = sel_get_any_uid ("doesNotRecognize:");
- if (__objc_responds_to (object, err_sel))
- {
- imp = get_implementation (object, object->class_pointer, err_sel);
- return (*imp) (object, err_sel, sel);
- }
-
- /* The object doesn't recognize the method. Check for responding to
- error:. If it does then sent it. */
- {
- char msg[256 + strlen ((const char *) sel_getName (sel))
- + strlen ((const char *) object->class_pointer->name)];
-
- sprintf (msg, "(%s) %s does not recognize %s",
- (CLS_ISMETA (object->class_pointer)
- ? "class"
- : "instance" ),
- object->class_pointer->name, sel_getName (sel));
-
- /* The object doesn't respond to doesNotRecognize:. Therefore, a
- default action is taken. */
- _objc_abort ("%s\n", msg);
-
- return 0;
- }
-}
-
-void
-__objc_print_dtable_stats (void)
-{
- int total = 0;
-
- objc_mutex_lock (__objc_runtime_mutex);
-
-#ifdef OBJC_SPARSE2
- printf ("memory usage: (%s)\n", "2-level sparse arrays");
-#else
- printf ("memory usage: (%s)\n", "3-level sparse arrays");
-#endif
-
- printf ("arrays: %d = %ld bytes\n", narrays,
- (long) ((size_t) narrays * sizeof (struct sarray)));
- total += narrays * sizeof (struct sarray);
- printf ("buckets: %d = %ld bytes\n", nbuckets,
- (long) ((size_t) nbuckets * sizeof (struct sbucket)));
- total += nbuckets * sizeof (struct sbucket);
-
- printf ("idxtables: %d = %ld bytes\n",
- idxsize, (long) ((size_t) idxsize * sizeof (void *)));
- total += idxsize * sizeof (void *);
- printf ("-----------------------------------\n");
- printf ("total: %d bytes\n", total);
- printf ("===================================\n");
-
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-static cache_ptr prepared_dtable_table = 0;
-
-/* This function is called by: objc_msg_lookup, get_imp and
- __objc_responds_to (and the dispatch table installation functions
- themselves) to install a dispatch table for a class.
-
- If CLS is a class, it installs instance methods.
- If CLS is a meta class, it installs class methods.
-
- In either case +initialize is invoked for the corresponding class.
-
- The implementation must insure that the dispatch table is not
- installed until +initialize completes. Otherwise it opens a
- potential race since the installation of the dispatch table is used
- as gate in regular method dispatch and we need to guarantee that
- +initialize is the first method invoked an that no other thread my
- dispatch messages to the class before +initialize completes. */
-static void
-__objc_install_dtable_for_class (Class cls)
-{
- /* If the class has not yet had its class links resolved, we must
- re-compute all class links. */
- if (! CLS_ISRESOLV (cls))
- __objc_resolve_class_links ();
-
- /* Make sure the super class has its dispatch table installed or is
- at least preparing. We do not need to send initialize for the
- super class since __objc_send_initialize will insure that. */
- if (cls->super_class
- && cls->super_class->dtable == __objc_uninstalled_dtable
- && !__objc_prepared_dtable_for_class (cls->super_class))
- {
- __objc_install_dtable_for_class (cls->super_class);
- /* The superclass initialisation may have also initialised the
- current class, in which case there is no more to do. */
- if (cls->dtable != __objc_uninstalled_dtable)
- return;
- }
-
- /* We have already been prepared but +initialize hasn't completed.
- The +initialize implementation is probably sending 'self'
- messages. We rely on _objc_get_prepared_imp to retrieve the
- implementation pointers. */
- if (__objc_prepared_dtable_for_class (cls))
- return;
-
- /* We have this function cache the implementation pointers for
- _objc_get_prepared_imp but the dispatch table won't be initilized
- until __objc_send_initialize completes. */
- __objc_prepare_dtable_for_class (cls);
-
- /* We may have already invoked +initialize but
- __objc_update_dispatch_table_for_class invoked by
- class_add_method_list may have reset dispatch table. */
-
- /* Call +initialize. If we are a real class, we are installing
- instance methods. If we are a meta class, we are installing
- class methods. The __objc_send_initialize itself will insure
- that the message is called only once per class. */
- if (CLS_ISCLASS (cls))
- __objc_send_initialize (cls);
- else
- {
- /* Retrieve the class from the meta class. */
- Class c = objc_getClass (cls->name);
- assert (CLS_ISMETA (cls));
- assert (c);
- __objc_send_initialize (c);
- }
-
- /* We install the dispatch table correctly when +initialize completed. */
- __objc_install_prepared_dtable_for_class (cls);
-}
-
-/* Builds the dispatch table for the class CLS and stores it in a
- place where it can be retrieved by __objc_get_prepared_imp until
- __objc_install_prepared_dtable_for_class installs it into the
- class. The dispatch table should not be installed into the class
- until +initialize has completed. */
-static void
-__objc_prepare_dtable_for_class (Class cls)
-{
- struct sarray *dtable;
- struct sarray *super_dtable;
-
- /* This table could be initialized in init.c. We cannot use the
- class name since the class maintains the instance methods and the
- meta class maintains the the class methods yet both share the
- same name. Classes should be unique in any program. */
- if (! prepared_dtable_table)
- prepared_dtable_table
- = objc_hash_new (32,
- (hash_func_type) objc_hash_ptr,
- (compare_func_type) objc_compare_ptrs);
-
- /* If the class has not yet had its class links resolved, we must
- re-compute all class links. */
- if (! CLS_ISRESOLV (cls))
- __objc_resolve_class_links ();
-
- assert (cls);
- assert (cls->dtable == __objc_uninstalled_dtable);
-
- /* If there is already a prepared dtable for this class, we must
- replace it with a new version (since there must have been methods
- added to or otherwise modified in the class while executing
- +initialize, and the table needs to be recomputed. */
- dtable = __objc_prepared_dtable_for_class (cls);
- if (dtable != 0)
- {
- objc_hash_remove (prepared_dtable_table, cls);
- sarray_free (dtable);
- }
-
- /* Now prepare the dtable for population. */
- assert (cls != cls->super_class);
- if (cls->super_class)
- {
- /* Inherit the method list from the super class. Yet the super
- class may still be initializing in the case when a class
- cluster sub class initializes its super classes. */
- if (cls->super_class->dtable == __objc_uninstalled_dtable)
- __objc_install_dtable_for_class (cls->super_class);
-
- super_dtable = cls->super_class->dtable;
- /* If the dispatch table is not yet installed, we are still in
- the process of executing +initialize. Yet the dispatch table
- should be available. */
- if (super_dtable == __objc_uninstalled_dtable)
- super_dtable = __objc_prepared_dtable_for_class (cls->super_class);
-
- assert (super_dtable);
- dtable = sarray_lazy_copy (super_dtable);
- }
- else
- dtable = sarray_new (__objc_selector_max_index, 0);
-
- __objc_install_methods_in_dtable (dtable, cls->methods);
-
- objc_hash_add (&prepared_dtable_table,
- cls,
- dtable);
-}
-
-/* This wrapper only exists to allow an easy replacement of the lookup
- implementation and it is expected that the compiler will optimize
- it away. */
-static struct sarray *
-__objc_prepared_dtable_for_class (Class cls)
-{
- struct sarray *dtable = 0;
- assert (cls);
- if (prepared_dtable_table)
- dtable = objc_hash_value_for_key (prepared_dtable_table, cls);
- /* dtable my be nil, since we call this to check whether we are
- currently preparing before we start preparing. */
- return dtable;
-}
-
-/* Helper function for messages sent to CLS or implementation pointers
- retrieved from CLS during +initialize before the dtable is
- installed. When a class implicitly initializes another class which
- in turn implicitly invokes methods in this class, before the
- implementation of +initialize of CLS completes, this returns the
- expected implementation. Forwarding remains the responsibility of
- objc_msg_lookup. This function should only be called under the
- global lock. */
-static IMP
-__objc_get_prepared_imp (Class cls,SEL sel)
-{
- struct sarray *dtable;
- IMP imp;
-
- assert (cls);
- assert (sel);
- assert (cls->dtable == __objc_uninstalled_dtable);
- dtable = __objc_prepared_dtable_for_class (cls);
-
- assert (dtable);
- assert (dtable != __objc_uninstalled_dtable);
- imp = sarray_get_safe (dtable, (size_t) sel->sel_id);
-
- /* imp may be Nil if the method does not exist and we may fallback
- to the forwarding implementation later. */
- return imp;
-}
-
-/* When this function is called +initialize should be completed. So
- now we are safe to install the dispatch table for the class so that
- they become available for other threads that may be waiting in the
- lock. */
-static void
-__objc_install_prepared_dtable_for_class (Class cls)
-{
- assert (cls);
- assert (cls->dtable == __objc_uninstalled_dtable);
- cls->dtable = __objc_prepared_dtable_for_class (cls);
-
- assert (cls->dtable);
- assert (cls->dtable != __objc_uninstalled_dtable);
- objc_hash_remove (prepared_dtable_table, cls);
-}
diff --git a/libgcobol/thr.c b/libgcobol/thr.c
deleted file mode 100644
index 8a85f4c5ae39..000000000000
--- a/libgcobol/thr.c
+++ /dev/null
@@ -1,543 +0,0 @@
-/* GNU Objective C Runtime Thread Interface
- Copyright (C) 1996-2022 Free Software Foundation, Inc.
- Contributed by Galen C. Hunt (gchunt@cs.rochester.edu)
-
-This file is part of GCC.
-
-GCC 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, or (at your option) any later version.
-
-GCC 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.
-
-Under Section 7 of GPL version 3, you are granted additional
-permissions described in the GCC Runtime Library Exception, version
-3.1, as published by the Free Software Foundation.
-
-You should have received a copy of the GNU General Public License and
-a copy of the GCC Runtime Library Exception along with this program;
-see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
-<http://www.gnu.org/licenses/>. */
-
-#include "objc-private/common.h"
-#include "objc-private/error.h"
-#define _LIBOBJC
-#include "config.h"
-#include "tconfig.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "defaults.h"
-#include "objc/thr.h"
-#include "objc/message.h" /* For objc_msg_lookup(). */
-#include "objc/runtime.h"
-#include "objc-private/module-abi-8.h"
-#include "objc-private/runtime.h"
-#include <gthr.h>
-
-#include <stdlib.h>
-
-/* Global exit status. */
-int __objc_thread_exit_status = 0;
-
-/* Flag which lets us know if we ever became multi threaded. */
-int __objc_is_multi_threaded = 0;
-
-/* The hook function called when the runtime becomes multi
- threaded. */
-objc_thread_callback _objc_became_multi_threaded = NULL;
-
-/* Use this to set the hook function that will be called when the
- runtime initially becomes multi threaded. The hook function is
- only called once, meaning only when the 2nd thread is spawned, not
- for each and every thread.
-
- It returns the previous hook function or NULL if there is none.
-
- A program outside of the runtime could set this to some function so
- it can be informed; for example, the GNUstep Base Library sets it
- so it can implement the NSBecomingMultiThreaded notification. */
-objc_thread_callback objc_set_thread_callback (objc_thread_callback func)
-{
- objc_thread_callback temp = _objc_became_multi_threaded;
- _objc_became_multi_threaded = func;
- return temp;
-}
-
-/* Private functions.
-
- These functions are utilized by the runtime, but they are not
- considered part of the public interface. */
-
-/* Initialize the threads subsystem. */
-int
-__objc_init_thread_system(void)
-{
- return __gthread_objc_init_thread_system ();
-}
-
-/* First function called in a thread, starts everything else.
-
- This function is passed to the backend by objc_thread_detach as the
- starting function for a new thread. */
-struct __objc_thread_start_state
-{
- SEL selector;
- id object;
- id argument;
-};
-
-static void __attribute__((noreturn))
-__objc_thread_detach_function (struct __objc_thread_start_state *istate)
-{
- /* Valid state? */
- if (istate)
- {
- id (*imp) (id, SEL, id);
- SEL selector = istate->selector;
- id object = istate->object;
- id argument = istate->argument;
-
- /* Don't need anymore so free it. */
- objc_free (istate);
-
- /* Clear out the thread local storage. */
- objc_thread_set_data (NULL);
-
- /* Check to see if we just became multi threaded. */
- if (! __objc_is_multi_threaded)
- {
- __objc_is_multi_threaded = 1;
-
- /* Call the hook function. */
- if (_objc_became_multi_threaded != NULL)
- (*_objc_became_multi_threaded) ();
- }
-
- /* Call the method. */
- if ((imp = (id (*) (id, SEL, id))objc_msg_lookup (object, selector)))
- (*imp) (object, selector, argument);
- else
- {
- /* FIXME: Should we abort here ? */
- _objc_abort ("objc_thread_detach called with bad selector.\n");
- }
- }
- else
- {
- /* FIXME: Should we abort here ? */
- _objc_abort ("objc_thread_detach called with NULL state.\n");
- }
-
- /* Exit the thread. */
- objc_thread_exit ();
-
- /* Make sure compiler detects no return. */
- __builtin_trap ();
-}
-
-/* Public functions.
-
- These functions constitute the public interface to the Objective-C
- thread and mutex functionality. */
-
-/* Detach a new thread of execution and return its id. Returns NULL
- if fails. Thread is started by sending message with selector to
- object. Message takes a single argument. */
-objc_thread_t
-objc_thread_detach (SEL selector, id object, id argument)
-{
- struct __objc_thread_start_state *istate;
- objc_thread_t thread_id = NULL;
-
- /* Allocate the state structure. */
- if (!(istate = (struct __objc_thread_start_state *)objc_malloc
- (sizeof (*istate))))
- return NULL;
-
- /* Initialize the state structure. */
- istate->selector = selector;
- istate->object = object;
- istate->argument = argument;
-
- /* Lock access. */
- objc_mutex_lock (__objc_runtime_mutex);
-
- /* Call the backend to spawn the thread. */
- if ((thread_id = __gthread_objc_thread_detach ((void *)__objc_thread_detach_function,
- istate)) == NULL)
- {
- /* Failed! */
- objc_mutex_unlock (__objc_runtime_mutex);
- objc_free (istate);
- return NULL;
- }
-
- /* Increment our thread counter. */
- __objc_runtime_threads_alive++;
- objc_mutex_unlock (__objc_runtime_mutex);
-
- return thread_id;
-}
-
-/* Set the current thread's priority. */
-int
-objc_thread_set_priority (int priority)
-{
- return __gthread_objc_thread_set_priority (priority);
-}
-
-/* Return the current thread's priority. */
-int
-objc_thread_get_priority (void)
-{
- return __gthread_objc_thread_get_priority ();
-}
-
-/* Yield our process time to another thread. Any BUSY waiting that is
- done by a thread should use this function to make sure that other
- threads can make progress even on a lazy uniprocessor system. */
-void
-objc_thread_yield (void)
-{
- __gthread_objc_thread_yield ();
-}
-
-/* Terminate the current tread. Doesn't return. Actually, if it
- failed returns -1. */
-int
-objc_thread_exit (void)
-{
- /* Decrement our counter of the number of threads alive. */
- objc_mutex_lock (__objc_runtime_mutex);
- __objc_runtime_threads_alive--;
- objc_mutex_unlock (__objc_runtime_mutex);
-
- /* Call the backend to terminate the thread. */
- return __gthread_objc_thread_exit ();
-}
-
-/* Returns an integer value which uniquely describes a thread. Must
- not be NULL which is reserved as a marker for "no thread". */
-objc_thread_t
-objc_thread_id (void)
-{
- return __gthread_objc_thread_id ();
-}
-
-/* Sets the thread's local storage pointer. Returns 0 if successful
- or -1 if failed. */
-int
-objc_thread_set_data (void *value)
-{
- return __gthread_objc_thread_set_data (value);
-}
-
-/* Returns the thread's local storage pointer. Returns NULL on
- failure. */
-void *
-objc_thread_get_data (void)
-{
- return __gthread_objc_thread_get_data ();
-}
-
-/* Public mutex functions */
-
-/* Allocate a mutex. Return the mutex pointer if successful or NULL
- if the allocation failed for any reason. */
-objc_mutex_t
-objc_mutex_allocate (void)
-{
- objc_mutex_t mutex;
-
- /* Allocate the mutex structure. */
- if (! (mutex = (objc_mutex_t)objc_malloc (sizeof (struct objc_mutex))))
- return NULL;
-
- /* Call backend to create the mutex. */
- if (__gthread_objc_mutex_allocate (mutex))
- {
- /* Failed! */
- objc_free (mutex);
- return NULL;
- }
-
- /* Initialize mutex. */
- mutex->owner = NULL;
- mutex->depth = 0;
- return mutex;
-}
-
-/* Deallocate a mutex. Note that this includes an implicit mutex_lock
- to insure that no one else is using the lock. It is legal to
- deallocate a lock if we have a lock on it, but illegal to
- deallocate a lock held by anyone else. Returns the number of locks
- on the thread. (1 for deallocate). */
-int
-objc_mutex_deallocate (objc_mutex_t mutex)
-{
- int depth;
-
- /* Valid mutex? */
- if (! mutex)
- return -1;
-
- /* Acquire lock on mutex. */
- depth = objc_mutex_lock (mutex);
-
- /* Call backend to destroy mutex. */
- if (__gthread_objc_mutex_deallocate (mutex))
- return -1;
-
- /* Free the mutex structure. */
- objc_free (mutex);
-
- /* Return last depth. */
- return depth;
-}
-
-/* Grab a lock on a mutex. If this thread already has a lock on this
- mutex then we increment the lock count. If another thread has a
- lock on the mutex we block and wait for the thread to release the
- lock. Returns the lock count on the mutex held by this thread. */
-int
-objc_mutex_lock (objc_mutex_t mutex)
-{
- objc_thread_t thread_id;
- int status;
-
- /* Valid mutex? */
- if (! mutex)
- return -1;
-
- /* If we already own the lock then increment depth. */
- thread_id = __gthread_objc_thread_id ();
- if (mutex->owner == thread_id)
- return ++mutex->depth;
-
- /* Call the backend to lock the mutex. */
- status = __gthread_objc_mutex_lock (mutex);
-
- /* Failed? */
- if (status)
- return status;
-
- /* Successfully locked the thread. */
- mutex->owner = thread_id;
- return mutex->depth = 1;
-}
-
-/* Try to grab a lock on a mutex. If this thread already has a lock
- on this mutex then we increment the lock count and return it. If
- another thread has a lock on the mutex returns -1. */
-int
-objc_mutex_trylock (objc_mutex_t mutex)
-{
- objc_thread_t thread_id;
- int status;
-
- /* Valid mutex? */
- if (! mutex)
- return -1;
-
- /* If we already own the lock then increment depth. */
- thread_id = __gthread_objc_thread_id ();
- if (mutex->owner == thread_id)
- return ++mutex->depth;
-
- /* Call the backend to try to lock the mutex. */
- status = __gthread_objc_mutex_trylock (mutex);
-
- /* Failed? */
- if (status)
- return status;
-
- /* Successfully locked the thread. */
- mutex->owner = thread_id;
- return mutex->depth = 1;
-}
-
-/* Unlocks the mutex by one level. Decrements the lock count on this
- mutex by one. If the lock count reaches zero, release the lock on
- the mutex. Returns the lock count on the mutex. It is an error to
- attempt to unlock a mutex which this thread doesn't hold in which
- case return -1 and the mutex is unaffected. */
-int
-objc_mutex_unlock (objc_mutex_t mutex)
-{
- objc_thread_t thread_id;
- int status;
-
- /* Valid mutex? */
- if (! mutex)
- return -1;
-
- /* If another thread owns the lock then abort. */
- thread_id = __gthread_objc_thread_id ();
- if (mutex->owner != thread_id)
- return -1;
-
- /* Decrement depth and return. */
- if (mutex->depth > 1)
- return --mutex->depth;
-
- /* Depth down to zero so we are no longer the owner. */
- mutex->depth = 0;
- mutex->owner = NULL;
-
- /* Have the backend unlock the mutex. */
- status = __gthread_objc_mutex_unlock (mutex);
-
- /* Failed? */
- if (status)
- return status;
-
- return 0;
-}
-
-/* Public condition mutex functions */
-
-/* Allocate a condition. Return the condition pointer if successful
- or NULL if the allocation failed for any reason. */
-objc_condition_t
-objc_condition_allocate (void)
-{
- objc_condition_t condition;
-
- /* Allocate the condition mutex structure. */
- if (! (condition =
- (objc_condition_t) objc_malloc (sizeof (struct objc_condition))))
- return NULL;
-
- /* Call the backend to create the condition mutex. */
- if (__gthread_objc_condition_allocate (condition))
- {
- /* Failed! */
- objc_free (condition);
- return NULL;
- }
-
- /* Success! */
- return condition;
-}
-
-/* Deallocate a condition. Note that this includes an implicit
- condition_broadcast to insure that waiting threads have the
- opportunity to wake. It is legal to dealloc a condition only if no
- other thread is/will be using it. Here we do NOT check for other
- threads waiting but just wake them up. */
-int
-objc_condition_deallocate (objc_condition_t condition)
-{
- /* Broadcast the condition. */
- if (objc_condition_broadcast (condition))
- return -1;
-
- /* Call the backend to destroy. */
- if (__gthread_objc_condition_deallocate (condition))
- return -1;
-
- /* Free the condition mutex structure. */
- objc_free (condition);
-
- return 0;
-}
-
-/* Wait on the condition unlocking the mutex until
- objc_condition_signal () or objc_condition_broadcast () are called
- for the same condition. The given mutex *must* have the depth set
- to 1 so that it can be unlocked here, so that someone else can lock
- it and signal/broadcast the condition. The mutex is used to lock
- access to the shared data that make up the "condition"
- predicate. */
-int
-objc_condition_wait (objc_condition_t condition, objc_mutex_t mutex)
-{
- objc_thread_t thread_id;
-
- /* Valid arguments? */
- if (! mutex || ! condition)
- return -1;
-
- /* Make sure we are owner of mutex. */
- thread_id = __gthread_objc_thread_id ();
- if (mutex->owner != thread_id)
- return -1;
-
- /* Cannot be locked more than once. */
- if (mutex->depth > 1)
- return -1;
-
- /* Virtually unlock the mutex. */
- mutex->depth = 0;
- mutex->owner = (objc_thread_t)NULL;
-
- /* Call the backend to wait. */
- __gthread_objc_condition_wait (condition, mutex);
-
- /* Make ourselves owner of the mutex. */
- mutex->owner = thread_id;
- mutex->depth = 1;
-
- return 0;
-}
-
-/* Wake up all threads waiting on this condition. It is recommended
- that the called would lock the same mutex as the threads in
- objc_condition_wait before changing the "condition predicate" and
- make this call and unlock it right away after this call. */
-int
-objc_condition_broadcast (objc_condition_t condition)
-{
- /* Valid condition mutex? */
- if (! condition)
- return -1;
-
- return __gthread_objc_condition_broadcast (condition);
-}
-
-/* Wake up one thread waiting on this condition. It is recommended
- that the called would lock the same mutex as the threads in
- objc_condition_wait before changing the "condition predicate" and
- make this call and unlock it right away after this call. */
-int
-objc_condition_signal (objc_condition_t condition)
-{
- /* Valid condition mutex? */
- if (! condition)
- return -1;
-
- return __gthread_objc_condition_signal (condition);
-}
-
-/* Make the objc thread system aware that a thread which is managed
- (started, stopped) by external code could access objc facilities
- from now on. This is used when you are interfacing with some
- external non-objc-based environment/system - you must call
- objc_thread_add () before an alien thread makes any calls to
- Objective-C. Do not cause the _objc_became_multi_threaded hook to
- be executed. */
-void
-objc_thread_add (void)
-{
- objc_mutex_lock (__objc_runtime_mutex);
- __objc_is_multi_threaded = 1;
- __objc_runtime_threads_alive++;
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
-/* Make the objc thread system aware that a thread managed (started,
- stopped) by some external code will no longer access objc and thus
- can be forgotten by the objc thread system. Call
- objc_thread_remove () when your alien thread is done with making
- calls to Objective-C. */
-void
-objc_thread_remove (void)
-{
- objc_mutex_lock (__objc_runtime_mutex);
- __objc_runtime_threads_alive--;
- objc_mutex_unlock (__objc_runtime_mutex);
-}
-
--
GitLab