diff options
Diffstat (limited to 'Ada95/src')
33 files changed, 607 insertions, 725 deletions
diff --git a/Ada95/src/Makefile.in b/Ada95/src/Makefile.in index 9962859ba4b1..bdfe0a81e5e7 100644 --- a/Ada95/src/Makefile.in +++ b/Ada95/src/Makefile.in @@ -1,5 +1,5 @@ ############################################################################## -# Copyright (c) 1998-2010,2011 Free Software Foundation, Inc. # +# Copyright (c) 1998-2018,2019 Free Software Foundation, Inc. # # # # Permission is hereby granted, free of charge, to any person obtaining a # # copy of this software and associated documentation files (the "Software"), # @@ -28,14 +28,17 @@ # # Author: Juergen Pfeifer, 1996 # -# $Id: Makefile.in,v 1.62 2011/04/30 22:24:45 tom Exp $ +# $Id: Makefile.in,v 1.87 2019/09/07 20:53:06 tom Exp $ # .SUFFIXES: -SHELL = /bin/sh +SHELL = @SHELL@ VPATH = @srcdir@ THIS = Makefile +ADA_MFLAGS = @cf_cv_makeflags@ +@SET_MAKE@ + MODEL = ../../@DFT_OBJ_SUBDIR@ DESTDIR = @DESTDIR@ @@ -51,7 +54,7 @@ LIBDIR = $(DESTDIR)$(libdir) ADA_INCLUDE = $(DESTDIR)@ADA_INCLUDE@ ADA_OBJECTS = $(DESTDIR)@ADA_OBJECTS@ -INSTALL = @INSTALL@ +INSTALL = @INSTALL@ @INSTALL_OPT_O@ INSTALL_LIB = @INSTALL@ @INSTALL_LIB@ AR = @AR@ @@ -80,14 +83,14 @@ LDFLAGS = @LDFLAGS@ @LD_MODEL@ @LIBS@ RANLIB = @RANLIB@ ################################################################################ -ADA = @cf_ada_compiler@ +ADA = @cf_ada_compiler@ ADAPREP = gnatprep -ADAFLAGS = @ADAFLAGS@ -I. -I$(srcdir) +ADAFLAGS = @ADAFLAGS@ -I. -I$(srcdir) -LIB_NAME = AdaCurses +LIB_NAME = @ADA_LIBNAME@ SONAME = @ADA_SHAREDLIB@ -GNAT_PROJECT = $(srcdir)/library.gpr +GNAT_PROJECT = @ADA_LIBNAME@.gpr # build/source are the Ada95 tree BUILD_DIR = .. @@ -96,8 +99,8 @@ SOURCE_DIR = .. BUILD_DIR_LIB = $(BUILD_DIR)/lib SOURCE_DIR_SRC = $(SOURCE_DIR)/src -ADAMAKE = @cf_ada_make@ -ADAMAKEFLAGS = \ +ADAMAKE = @cf_ada_make@ +ADAMAKEFLAGS = \ -P$(GNAT_PROJECT) \ -XBUILD_DIR=`cd $(BUILD_DIR);pwd` \ -XSOURCE_DIR=`cd $(SOURCE_DIR);pwd` \ @@ -179,7 +182,10 @@ $(LIBDIR) \ $(BUILD_DIR_LIB) : mkdir -p $@ -sources : +$(GENERATED_SOURCES) : + cd ../gen; $(MAKE) $(ADA_MFLAGS) + +sources : $(GENERATED_SOURCES) @echo made $@ libs \ @@ -207,7 +213,7 @@ clean :: mostlyclean rm -f $(ABASE)-trace.adb distclean :: clean - rm -f Makefile + rm -f Makefile library.gpr realclean :: distclean @@ -215,27 +221,33 @@ BASEDEPS=$(ABASE).ads $(ABASE)-aux.ads $(ABASE).adb $(ABASE)-trace.adb : $(srcdir)/$(ABASE)-trace.adb_p rm -f $@ - $(ADAPREP) -DADA_TRACE=@ADA_TRACE@ -DPRAGMA_UNREF=@PRAGMA_UNREF@ $(srcdir)/$(ABASE)-trace.adb_p $@ + $(ADAPREP) -DADA_TRACE=@ADA_TRACE@ @GNATPREP_OPTS@ $(srcdir)/$(ABASE)-trace.adb_p $@ ############################################################################### # Use these definitions when building a shared library. -SHARED_C_OBJS = c_varargs_to_ada.o ncurses_compat.o +SHARED_C_OBJS = c_varargs_to_ada.o c_threaded_variables.o ncurses_compat.o SHARED_OBJS = $(SHARED_C_OBJS) @USE_OLD_MAKERULES@$(LIBOBJS) @cf_generic_objects@ c_varargs_to_ada.o : $(srcdir)/c_varargs_to_ada.c $(CC) $(CFLAGS_DEFAULT) -c -o $@ $(srcdir)/c_varargs_to_ada.c +c_threaded_variables.o : $(srcdir)/c_threaded_variables.c + $(CC) $(CFLAGS_DEFAULT) -c -o $@ $(srcdir)/c_threaded_variables.c + ncurses_compat.o : $(srcdir)/ncurses_compat.c $(CC) $(CFLAGS_DEFAULT) -c -o $@ $(srcdir)/ncurses_compat.c ############################################################################### # Use these definitions when building a static library. -STATIC_C_OBJS = static_c_varargs_to_ada.o static_ncurses_compat.o +STATIC_C_OBJS = static_c_varargs_to_ada.o static_c_threaded_variables.o static_ncurses_compat.o STATIC_OBJS = $(STATIC_C_OBJS) @USE_OLD_MAKERULES@$(LIBOBJS) @cf_generic_objects@ static_c_varargs_to_ada.o : $(srcdir)/c_varargs_to_ada.c $(CC) $(CFLAGS_NORMAL) -c -o $@ $(srcdir)/c_varargs_to_ada.c +static_c_threaded_variables.o : $(srcdir)/c_threaded_variables.c + $(CC) $(CFLAGS_NORMAL) -c -o $@ $(srcdir)/c_threaded_variables.c + static_ncurses_compat.o : $(srcdir)/ncurses_compat.c $(CC) $(CFLAGS_NORMAL) -c -o $@ $(srcdir)/ncurses_compat.c @@ -258,8 +270,14 @@ STATIC_DIRS = \ @USE_GNAT_PROJECTS@ $(ABASE)-trace.adb \ @USE_GNAT_PROJECTS@ $(STATIC_C_OBJS) \ @USE_GNAT_PROJECTS@ $(STATIC_DIRS) +@USE_GNAT_PROJECTS@ @cf_ada_config@gprconfig --batch --config=Ada --config=C,,,,@cf_ada_config_C@ +@USE_GNAT_PROJECTS@ -rm -f $(GNAT_PROJECT) +@USE_GNAT_PROJECTS@ $(SHELL) $(srcdir)/library-cfg.sh static $(srcdir)/library.gpr $(CFLAGS_NORMAL) >$(GNAT_PROJECT) +@USE_GNAT_PROJECTS@ @echo "Using GNAT Project:" +@USE_GNAT_PROJECTS@ @-$(SHELL) -c "diff -u $(srcdir)/library.gpr $(GNAT_PROJECT); exit 0" @USE_GNAT_PROJECTS@ $(ADAMAKE) $(ADAMAKEFLAGS) -XLIB_KIND=static @USE_GNAT_PROJECTS@ $(AR) $(ARFLAGS) $@ $(STATIC_C_OBJS) +@USE_GNAT_PROJECTS@ -rm -f $(GNAT_PROJECT) @USE_GNAT_PROJECTS@ @USE_GNAT_LIBRARIES@install \ @USE_GNAT_LIBRARIES@install.libs :: \ @@ -290,7 +308,13 @@ SHARED_DIRS = \ @MAKE_ADA_SHAREDLIB@ $(SHARED_DIRS) \ @MAKE_ADA_SHAREDLIB@ $(SHARED_OBJS) @MAKE_ADA_SHAREDLIB@ cp $(SHARED_OBJS) $(BUILD_DIR)/dynamic-obj/ +@MAKE_ADA_SHAREDLIB@ @cf_ada_config@gprconfig --batch --config=Ada --config=C,,,,@cf_ada_config_C@ +@MAKE_ADA_SHAREDLIB@ -rm -f $(GNAT_PROJECT) +@MAKE_ADA_SHAREDLIB@ $(SHELL) $(srcdir)/library-cfg.sh dynamic $(srcdir)/library.gpr $(CFLAGS_SHARED) >$(GNAT_PROJECT) +@MAKE_ADA_SHAREDLIB@ @echo "Making Ada shared-lib:" +@MAKE_ADA_SHAREDLIB@ @-$(SHELL) -c "diff -u $(srcdir)/library.gpr $(GNAT_PROJECT); exit 0" @MAKE_ADA_SHAREDLIB@ $(ADAMAKE) $(ADAMAKEFLAGS) -XLIB_KIND=dynamic +@MAKE_ADA_SHAREDLIB@ -rm -f $(GNAT_PROJECT) install \ install.libs :: $(ADA_INCLUDE) @@ -328,6 +352,7 @@ uninstall.libs :: @MAKE_ADA_SHAREDLIB@ rm -f $(LIBDIR)/$(SHARED_LIBNAME) clean :: - rm -rf $(BUILD_DIR)/*-ali - rm -rf $(BUILD_DIR)/*-obj - rm -rf $(BUILD_DIR_LIB) + -rm -f default.cgpr + -rm -rf $(BUILD_DIR)/*-ali + -rm -rf $(BUILD_DIR)/*-obj + -rm -rf $(BUILD_DIR_LIB) diff --git a/Ada95/src/c_threaded_variables.c b/Ada95/src/c_threaded_variables.c new file mode 100644 index 000000000000..bc58c46abefe --- /dev/null +++ b/Ada95/src/c_threaded_variables.c @@ -0,0 +1,56 @@ +/**************************************************************************** + * Copyright (c) 2011,2014 Free Software Foundation, Inc. * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the * + * "Software"), to deal in the Software without restriction, including * + * without limitation the rights to use, copy, modify, merge, publish, * + * distribute, distribute with modifications, sublicense, and/or sell * + * copies of the Software, and to permit persons to whom the Software is * + * furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS * + * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. * + * IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, * + * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR * + * OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR * + * THE USE OR OTHER DEALINGS IN THE SOFTWARE. * + * * + * Except as contained in this notice, the name(s) of the above copyright * + * holders shall not be used in advertising or otherwise to promote the * + * sale, use or other dealings in this Software without prior written * + * authorization. * + ****************************************************************************/ + +/**************************************************************************** + * Author: Nicolas Boulenguez, 2011 * + ****************************************************************************/ + +#include "c_threaded_variables.h" + +#define WRAP(type, name) \ + type \ + name ## _as_function () \ + { \ + return name; \ + } +/* *INDENT-OFF* */ +WRAP(WINDOW *, stdscr) +WRAP(WINDOW *, curscr) + +WRAP(int, LINES) +WRAP(int, COLS) +WRAP(int, TABSIZE) +WRAP(int, COLORS) +WRAP(int, COLOR_PAIRS) + +chtype +acs_map_as_function(char inx) +{ + return acs_map[(unsigned char) inx]; +} +/* *INDENT-ON* */ diff --git a/Ada95/src/c_threaded_variables.h b/Ada95/src/c_threaded_variables.h new file mode 100644 index 000000000000..5f0f62f16333 --- /dev/null +++ b/Ada95/src/c_threaded_variables.h @@ -0,0 +1,58 @@ +/**************************************************************************** + * Copyright (c) 2011-2014,2015 Free Software Foundation, Inc. * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the * + * "Software"), to deal in the Software without restriction, including * + * without limitation the rights to use, copy, modify, merge, publish, * + * distribute, distribute with modifications, sublicense, and/or sell * + * copies of the Software, and to permit persons to whom the Software is * + * furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS * + * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. * + * IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, * + * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR * + * OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR * + * THE USE OR OTHER DEALINGS IN THE SOFTWARE. * + * * + * Except as contained in this notice, the name(s) of the above copyright * + * holders shall not be used in advertising or otherwise to promote the * + * sale, use or other dealings in this Software without prior written * + * authorization. * + ****************************************************************************/ + +/* $Id: c_threaded_variables.h,v 1.3 2015/08/06 23:09:47 tom Exp $ */ + +#ifndef __C_THREADED_VARIABLES_H +#define __C_THREADED_VARIABLES_H + +#include <ncurses_cfg.h> + +#if HAVE_INTTYPES_H +# include <inttypes.h> +#else +# if HAVE_STDINT_H +# include <stdint.h> +# endif +#endif + +#include <curses.h> + +extern WINDOW *stdscr_as_function(void); +extern WINDOW *curscr_as_function(void); + +extern int LINES_as_function(void); +extern int LINES_as_function(void); +extern int COLS_as_function(void); +extern int TABSIZE_as_function(void); +extern int COLORS_as_function(void); +extern int COLOR_PAIRS_as_function(void); + +extern chtype acs_map_as_function(char /* index */ ); + +#endif /* __C_THREADED_VARIABLES_H */ diff --git a/Ada95/src/c_varargs_to_ada.c b/Ada95/src/c_varargs_to_ada.c index ed236ddc90da..f0b1bbef01ff 100644 --- a/Ada95/src/c_varargs_to_ada.c +++ b/Ada95/src/c_varargs_to_ada.c @@ -1,5 +1,5 @@ /**************************************************************************** - * Copyright (c) 2011 Free Software Foundation, Inc. * + * Copyright (c) 2011,2014 Free Software Foundation, Inc. * * * * Permission is hereby granted, free of charge, to any person obtaining a * * copy of this software and associated documentation files (the * @@ -32,12 +32,12 @@ /* Version Control - $Id: c_varargs_to_ada.c,v 1.4 2011/03/19 19:07:39 tom Exp $ + $Id: c_varargs_to_ada.c,v 1.6 2014/05/24 21:32:18 tom Exp $ --------------------------------------------------------------------------*/ /* */ -#include <c_varargs_to_ada.h> +#include "c_varargs_to_ada.h" int set_field_type_alnum(FIELD *field, diff --git a/Ada95/src/c_varargs_to_ada.h b/Ada95/src/c_varargs_to_ada.h index ee6a7a7c1eb9..f2697058493e 100644 --- a/Ada95/src/c_varargs_to_ada.h +++ b/Ada95/src/c_varargs_to_ada.h @@ -1,5 +1,5 @@ /**************************************************************************** - * Copyright (c) 2011 Free Software Foundation, Inc. * + * Copyright (c) 2011,2015 Free Software Foundation, Inc. * * * * Permission is hereby granted, free of charge, to any person obtaining a * * copy of this software and associated documentation files (the * @@ -26,11 +26,19 @@ * authorization. * ****************************************************************************/ -/* $Id: c_varargs_to_ada.h,v 1.3 2011/03/19 19:07:41 tom Exp $ */ +/* $Id: c_varargs_to_ada.h,v 1.4 2015/08/06 23:08:47 tom Exp $ */ #ifndef __C_VARARGS_TO_ADA_H #define __C_VARARGS_TO_ADA_H +#ifdef HAVE_CONFIG_H +#include <ncurses_cfg.h> +#else +#include <ncurses.h> +#endif + +#include <stdlib.h> + #include <form.h> extern int set_field_type_alnum(FIELD * /* field */ , diff --git a/Ada95/src/library-cfg.sh b/Ada95/src/library-cfg.sh new file mode 100755 index 000000000000..005979f44467 --- /dev/null +++ b/Ada95/src/library-cfg.sh @@ -0,0 +1,72 @@ +#!/bin/sh +############################################################################## +# Copyright (c) 2016-2018,2019 Free Software Foundation, Inc. # +# # +# Permission is hereby granted, free of charge, to any person obtaining a # +# copy of this software and associated documentation files (the "Software"), # +# to deal in the Software without restriction, including without limitation # +# the rights to use, copy, modify, merge, publish, distribute, distribute # +# with modifications, sublicense, and/or sell copies of the Software, and to # +# permit persons to whom the Software is furnished to do so, subject to the # +# following conditions: # +# # +# The above copyright notice and this permission notice shall be included in # +# all copies or substantial portions of the Software. # +# # +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL # +# THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # +# DEALINGS IN THE SOFTWARE. # +# # +# Except as contained in this notice, the name(s) of the above copyright # +# holders shall not be used in advertising or otherwise to promote the sale, # +# use or other dealings in this Software without prior written # +# authorization. # +############################################################################## +# +# $Id: library-cfg.sh,v 1.6 2019/09/07 20:27:26 tom Exp $ +# +# Work around incompatible behavior introduced with gnat6, which causes +# gnatmake to attempt to compile all of the C objects which might be part of +# the project. This can only work if we provide the compiler flags (done here +# by making a copy of the project file with that information filled in). +model=$1 +shift 1 +input=$1 +shift 1 +param= +while test $# != 0 +do + case "x$1" in + *-[OgDIWf]*) + test -n "$param" && param="$param," + param="$param\"$1\"" + ;; + *) + echo "${0##*/}: ignored option $1" >&2 + ;; + esac + shift 1 +done + +SHARE="-- " +test "x$model" = "xdynamic" && SHARE= + +SCRIPT=library-cfg.tmp +cat >$SCRIPT <<EOF +/for Library_Options use /{ + s,-- ,$SHARE, +} +/for Default_Switches ("C") use/{ + s,-- ,, + s% use .*% use($param);% +} +EOF + +sed -f $SCRIPT $input +rc=$? +rm -f $SCRIPT +exit $? diff --git a/Ada95/src/library.gpr b/Ada95/src/library.gpr.in index 33e4a3c7d7e2..aeee4e2c8215 100644 --- a/Ada95/src/library.gpr +++ b/Ada95/src/library.gpr.in @@ -1,5 +1,5 @@ ------------------------------------------------------------------------------ --- Copyright (c) 2010,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 2010-2018,2019 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -25,10 +25,10 @@ -- sale, use or other dealings in this Software without prior written -- -- authorization. -- ------------------------------------------------------------------------------ --- $Id: library.gpr,v 1.7 2011/03/18 23:10:28 Nicolas.Boulenguez Exp $ +-- $Id: library.gpr.in,v 1.1 2019/09/07 20:29:02 tom Exp $ -- http://gcc.gnu.org/onlinedocs/gnat_ugn_unw/Library-Projects.html -- http://www.adaworld.com/debian/debian-ada-policy.html -project Library is +project AdaCurses is Build_Dir := External ("BUILD_DIR"); Source_Dir := External ("SOURCE_DIR"); Source_Dir2 := External ("SOURCE_DIR2"); @@ -43,7 +43,7 @@ project Library is for Source_Dirs use (Source_Dir & "/src", Source_Dir2, Build_Dir & "/src"); - for Library_Options use ("-lncurses", "-lpanel", "-lmenu", "-lform"); + -- for Library_Options use ("-lncurses@USE_LIB_SUFFIX@", "-lpanel@USE_LIB_SUFFIX@", "-lmenu@USE_LIB_SUFFIX@", "-lform@USE_LIB_SUFFIX@"); package Compiler is for Default_Switches ("Ada") use ("-g", @@ -51,6 +51,7 @@ project Library is "-gnatafno", "-gnatVa", -- All validity checks "-gnatwa"); -- Activate all optional errors + -- for Default_Switches ("C") use (CFLAGS) end Compiler; for Languages use ("C", "Ada"); -end Library; +end AdaCurses; diff --git a/Ada95/src/ncurses_compat.c b/Ada95/src/ncurses_compat.c index b3d0607a5ff2..e44f3d0fe39b 100644 --- a/Ada95/src/ncurses_compat.c +++ b/Ada95/src/ncurses_compat.c @@ -1,5 +1,5 @@ /**************************************************************************** - * Copyright (c) 2011 Free Software Foundation, Inc. * + * Copyright (c) 2011,2015 Free Software Foundation, Inc. * * * * Permission is hereby granted, free of charge, to any person obtaining a * * copy of this software and associated documentation files (the * @@ -32,12 +32,22 @@ /* Version Control - $Id: ncurses_compat.c,v 1.2 2011/03/28 00:29:04 tom Exp $ + $Id: ncurses_compat.c,v 1.3 2015/08/06 23:09:10 tom Exp $ --------------------------------------------------------------------------*/ /* * Provide compatibility with older versions of ncurses. */ +#include <ncurses_cfg.h> + +#if HAVE_INTTYPES_H +# include <inttypes.h> +#else +# if HAVE_STDINT_H +# include <stdint.h> +# endif +#endif + #include <curses.h> #if defined(NCURSES_VERSION_PATCH) @@ -49,7 +59,7 @@ extern int _nc_has_mouse(void); bool has_mouse(void) { - return (bool) _nc_has_mouse(); + return (bool)_nc_has_mouse(); } #endif diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-alpha.adb b/Ada95/src/terminal_interface-curses-forms-field_types-alpha.adb index 943362012394..9c614cacb800 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-alpha.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-alpha.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.11 $ --- $Date: 2011/03/19 00:45:37 $ +-- $Revision: 1.13 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -47,15 +47,11 @@ package body Terminal_Interface.Curses.Forms.Field_Types.Alpha is Typ : Alpha_Field) is function Set_Fld_Type (F : Field := Fld; - Arg1 : C_Int) return C_Int; + Arg1 : C_Int) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_alpha"); - Res : Eti_Error; begin - Res := Set_Fld_Type (Arg1 => C_Int (Typ.Minimum_Field_Width)); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => C_Int (Typ.Minimum_Field_Width))); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-alphanumeric.adb b/Ada95/src/terminal_interface-curses-forms-field_types-alphanumeric.adb index 53f66801e917..270906d40120 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-alphanumeric.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-alphanumeric.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.11 $ --- $Date: 2011/03/19 00:45:37 $ +-- $Revision: 1.13 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -47,15 +47,11 @@ package body Terminal_Interface.Curses.Forms.Field_Types.AlphaNumeric is Typ : AlphaNumeric_Field) is function Set_Fld_Type (F : Field := Fld; - Arg1 : C_Int) return C_Int; + Arg1 : C_Int) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_alnum"); - Res : Eti_Error; begin - Res := Set_Fld_Type (Arg1 => C_Int (Typ.Minimum_Field_Width)); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => C_Int (Typ.Minimum_Field_Width))); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration-ada.ads b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration-ada.ads index 48fad09c2f25..198071cf01c5 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration-ada.ads +++ b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration-ada.ads @@ -7,7 +7,7 @@ -- S P E C -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- Copyright (c) 1998,2003 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.10 $ +-- $Revision: 1.11 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ generic diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.adb b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.adb index 12648e5a1dcc..8d4c9cee49b7 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.10 $ +-- $Revision: 1.12 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; @@ -94,21 +94,18 @@ package body Terminal_Interface.Curses.Forms.Field_Types.Enumeration is function Set_Fld_Type (F : Field := Fld; Arg1 : chars_ptr_array; Arg2 : C_Int; - Arg3 : C_Int) return C_Int; + Arg3 : C_Int) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_enum"); - Res : Eti_Error; begin if Typ.Arr = null then raise Form_Exception; end if; - Res := Set_Fld_Type (Arg1 => Typ.Arr.all, - Arg2 => C_Int (Boolean'Pos (Typ.Case_Sensitive)), - Arg3 => C_Int (Boolean'Pos - (Typ.Match_Must_Be_Unique))); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception + (Set_Fld_Type + (Arg1 => Typ.Arr.all, + Arg2 => C_Int (Boolean'Pos (Typ.Case_Sensitive)), + Arg3 => C_Int (Boolean'Pos (Typ.Match_Must_Be_Unique)))); Wrap_Builtin (Fld, Typ, C_Choice_Router); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.ads b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.ads index e6924f6b19f9..52a35caa07b6 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.ads +++ b/Ada95/src/terminal_interface-curses-forms-field_types-enumeration.ads @@ -7,7 +7,7 @@ -- S P E C -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2018,2020 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.12 $ +-- $Revision: 1.14 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Interfaces.C.Strings; @@ -54,9 +54,9 @@ package Terminal_Interface.Curses.Forms.Field_Types.Enumeration is type Enumeration_Info (C : Positive) is record - Names : Enum_Array (1 .. C); Case_Sensitive : Boolean := False; Match_Must_Be_Unique : Boolean := False; + Names : Enum_Array (1 .. C); end record; type Enumeration_Field is new Field_Type with private; @@ -78,7 +78,7 @@ package Terminal_Interface.Curses.Forms.Field_Types.Enumeration is -- But we may want to release the field to release the memory allocated -- by it internally. After that the Enumeration field is no longer usable. - -- The next type defintions are all ncurses extensions. They are typically + -- The next type definitions are all ncurses extensions. They are typically -- not available in other curses implementations. procedure Set_Field_Type (Fld : Field; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-intfield.adb b/Ada95/src/terminal_interface-curses-forms-field_types-intfield.adb index b6229becefb9..5ec330535994 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-intfield.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-intfield.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.11 $ --- $Date: 2011/03/19 00:45:37 $ +-- $Revision: 1.13 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -49,17 +49,13 @@ package body Terminal_Interface.Curses.Forms.Field_Types.IntField is function Set_Fld_Type (F : Field := Fld; Arg1 : C_Int; Arg2 : C_Long_Int; - Arg3 : C_Long_Int) return C_Int; + Arg3 : C_Long_Int) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_integer"); - Res : Eti_Error; begin - Res := Set_Fld_Type (Arg1 => C_Int (Typ.Precision), - Arg2 => C_Long_Int (Typ.Lower_Limit), - Arg3 => C_Long_Int (Typ.Upper_Limit)); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => C_Int (Typ.Precision), + Arg2 => C_Long_Int (Typ.Lower_Limit), + Arg3 => C_Long_Int (Typ.Upper_Limit))); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-ipv4_address.adb b/Ada95/src/terminal_interface-curses-forms-field_types-ipv4_address.adb index 66e052942d37..978a47a1f0c7 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-ipv4_address.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-ipv4_address.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.11 $ --- $Date: 2011/03/19 00:45:37 $ +-- $Revision: 1.13 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -47,15 +47,11 @@ package body Terminal_Interface.Curses.Forms.Field_Types.IPV4_Address is Typ : Internet_V4_Address_Field) is function Set_Fld_Type (F : Field := Fld) - return C_Int; + return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_ipv4"); - Res : Eti_Error; begin - Res := Set_Fld_Type; - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-numeric.adb b/Ada95/src/terminal_interface-curses-forms-field_types-numeric.adb index b31dfa657a59..94e2aa702c41 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-numeric.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-numeric.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.12 $ --- $Date: 2011/03/19 00:45:37 $ +-- $Revision: 1.14 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Interfaces.C; @@ -52,17 +52,13 @@ package body Terminal_Interface.Curses.Forms.Field_Types.Numeric is function Set_Fld_Type (F : Field := Fld; Arg1 : C_Int; Arg2 : Double; - Arg3 : Double) return C_Int; + Arg3 : Double) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_numeric"); - Res : Eti_Error; begin - Res := Set_Fld_Type (Arg1 => C_Int (Typ.Precision), - Arg2 => Double (Typ.Lower_Limit), - Arg3 => Double (Typ.Upper_Limit)); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => C_Int (Typ.Precision), + Arg2 => Double (Typ.Lower_Limit), + Arg3 => Double (Typ.Upper_Limit))); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-regexp.adb b/Ada95/src/terminal_interface-curses-forms-field_types-regexp.adb index 55f0255071ab..f5ea0db2b11c 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-regexp.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-regexp.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.10 $ +-- $Revision: 1.12 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Interfaces.C; use Interfaces.C; @@ -46,21 +46,12 @@ package body Terminal_Interface.Curses.Forms.Field_Types.RegExp is procedure Set_Field_Type (Fld : Field; Typ : Regular_Expression_Field) is - type Char_Ptr is access all Interfaces.C.char; - function Set_Ftyp (F : Field := Fld; - Arg1 : Char_Ptr) return C_Int; + Arg1 : char_array) return Eti_Error; pragma Import (C, Set_Ftyp, "set_field_type_regexp"); - Txt : char_array (0 .. Typ.Regular_Expression.all'Length); - Len : size_t; - Res : Eti_Error; begin - To_C (Typ.Regular_Expression.all, Txt, Len); - Res := Set_Ftyp (Arg1 => Txt (Txt'First)'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Ftyp (Arg1 => To_C (Typ.Regular_Expression.all))); Wrap_Builtin (Fld, Typ); end Set_Field_Type; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-user-choice.adb b/Ada95/src/terminal_interface-curses-forms-field_types-user-choice.adb index 3a7e6b5aeb2e..8414cd0385c7 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-user-choice.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-user-choice.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2008,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.17 $ --- $Date: 2011/03/22 10:53:37 $ +-- $Revision: 1.20 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with System.Address_To_Access_Conversions; @@ -53,7 +53,7 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User.Choice is Result : Boolean; Udf : constant User_Defined_Field_Type_With_Choice_Access := User_Defined_Field_Type_With_Choice_Access - (Argument_Access (Argument_Conversions.To_Pointer (Usr)).Typ); + (Argument_Access (Argument_Conversions.To_Pointer (Usr)).all.Typ); begin Result := Next (Fld, Udf.all); return Curses_Bool (Boolean'Pos (Result)); @@ -65,7 +65,7 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User.Choice is Result : Boolean; Udf : constant User_Defined_Field_Type_With_Choice_Access := User_Defined_Field_Type_With_Choice_Access - (Argument_Access (Argument_Conversions.To_Pointer (Usr)).Typ); + (Argument_Access (Argument_Conversions.To_Pointer (Usr)).all.Typ); begin Result := Previous (Fld, Udf.all); return Curses_Bool (Boolean'Pos (Result)); @@ -88,16 +88,12 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User.Choice is Make_Arg'Access, Copy_Arg'Access, Free_Arg'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Res); Res := Set_Fieldtype_Choice (T, Generic_Next'Access, Generic_Prev'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Res); end if; M_Generic_Choice := T; end if; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-user.adb b/Ada95/src/terminal_interface-curses-forms-field_types-user.adb index 2dd295db7e76..98bcd2442d43 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types-user.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types-user.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.21 $ --- $Date: 2011/03/23 00:44:58 $ +-- $Revision: 1.23 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with System.Address_To_Access_Conversions; @@ -53,11 +53,9 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User is function Set_Fld_Type (F : Field := Fld; Cft : C_Field_Type := C_Generic_Type; Arg1 : Argument_Access) - return C_Int; + return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_user"); - Res : Eti_Error; - function Allocate_Arg (T : User_Defined_Field_Type'Class) return Argument_Access is @@ -70,10 +68,7 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User is end Allocate_Arg; begin - Res := Set_Fld_Type (Arg1 => Allocate_Arg (Typ)); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => Allocate_Arg (Typ))); end Set_Field_Type; package Argument_Conversions is @@ -120,9 +115,7 @@ package body Terminal_Interface.Curses.Forms.Field_Types.User is Make_Arg'Access, Copy_Arg'Access, Free_Arg'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Res); end if; M_Generic_Type := T; end if; diff --git a/Ada95/src/terminal_interface-curses-forms-field_types.adb b/Ada95/src/terminal_interface-curses-forms-field_types.adb index 5195a20a499c..bda6e51b088f 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_types.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_types.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.25 $ --- $Date: 2011/03/22 23:22:27 $ +-- $Revision: 1.28 $ +-- $Date: 2014/09/13 19:00:47 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -76,9 +76,10 @@ package body Terminal_Interface.Curses.Forms.Field_Types is return null; else if Low_Level = M_Builtin_Router or else - Low_Level = M_Generic_Type or else - Low_Level = M_Choice_Router or else - Low_Level = M_Generic_Choice then + Low_Level = M_Generic_Type or else + Low_Level = M_Choice_Router or else + Low_Level = M_Generic_Choice + then Arg := Argument_Access (Argument_Conversions.To_Pointer (Get_Arg (Fld))); if Arg = null then @@ -130,10 +131,9 @@ package body Terminal_Interface.Curses.Forms.Field_Types is Usr_Arg : constant System.Address := Get_Arg (Fld); Low_Level : constant C_Field_Type := Get_Fieldtype (Fld); Arg : Argument_Access; - Res : Eti_Error; function Set_Fld_Type (F : Field := Fld; Cf : C_Field_Type := Cft; - Arg1 : Argument_Access) return C_Int; + Arg1 : Argument_Access) return Eti_Error; pragma Import (C, Set_Fld_Type, "set_field_type_user"); begin @@ -152,10 +152,7 @@ package body Terminal_Interface.Curses.Forms.Field_Types is end if; end if; - Res := Set_Fld_Type (Arg1 => Arg); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Type (Arg1 => Arg)); end if; end Wrap_Builtin; @@ -223,7 +220,6 @@ package body Terminal_Interface.Curses.Forms.Field_Types is -- function C_Builtin_Router return C_Field_Type is - Res : Eti_Error; T : C_Field_Type; begin if M_Builtin_Router = Null_Field_Type then @@ -232,13 +228,10 @@ package body Terminal_Interface.Curses.Forms.Field_Types is if T = Null_Field_Type then raise Form_Exception; else - Res := Set_Fieldtype_Arg (T, - Make_Arg'Access, - Copy_Arg'Access, - Free_Arg'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fieldtype_Arg (T, + Make_Arg'Access, + Copy_Arg'Access, + Free_Arg'Access)); end if; M_Builtin_Router := T; end if; @@ -250,7 +243,6 @@ package body Terminal_Interface.Curses.Forms.Field_Types is -- function C_Choice_Router return C_Field_Type is - Res : Eti_Error; T : C_Field_Type; begin if M_Choice_Router = Null_Field_Type then @@ -259,20 +251,14 @@ package body Terminal_Interface.Curses.Forms.Field_Types is if T = Null_Field_Type then raise Form_Exception; else - Res := Set_Fieldtype_Arg (T, - Make_Arg'Access, - Copy_Arg'Access, - Free_Arg'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fieldtype_Arg (T, + Make_Arg'Access, + Copy_Arg'Access, + Free_Arg'Access)); - Res := Set_Fieldtype_Choice (T, - Next_Router'Access, - Prev_Router'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fieldtype_Choice (T, + Next_Router'Access, + Prev_Router'Access)); end if; M_Choice_Router := T; end if; diff --git a/Ada95/src/terminal_interface-curses-forms-field_user_data.adb b/Ada95/src/terminal_interface-curses-forms-field_user_data.adb index 96178d8a9349..fc710b694646 100644 --- a/Ada95/src/terminal_interface-curses-forms-field_user_data.adb +++ b/Ada95/src/terminal_interface-curses-forms-field_user_data.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.13 $ +-- $Revision: 1.16 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -49,20 +49,15 @@ package body Terminal_Interface.Curses.Forms.Field_User_Data is -- | -- | -- | - use type Interfaces.C.int; - procedure Set_User_Data (Fld : Field; Data : User_Access) is function Set_Field_Userptr (Fld : Field; - Usr : User_Access) return C_Int; + Usr : User_Access) return Eti_Error; pragma Import (C, Set_Field_Userptr, "set_field_userptr"); - Res : constant Eti_Error := Set_Field_Userptr (Fld, Data); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Userptr (Fld, Data)); end Set_User_Data; -- | -- | diff --git a/Ada95/src/terminal_interface-curses-forms-form_user_data.adb b/Ada95/src/terminal_interface-curses-forms-form_user_data.adb index 84353eb55700..500ec130086f 100644 --- a/Ada95/src/terminal_interface-curses-forms-form_user_data.adb +++ b/Ada95/src/terminal_interface-curses-forms-form_user_data.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.13 $ +-- $Revision: 1.16 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ -- | @@ -47,8 +47,6 @@ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; package body Terminal_Interface.Curses.Forms.Form_User_Data is - use type Interfaces.C.int; - -- | -- | -- | @@ -56,14 +54,11 @@ package body Terminal_Interface.Curses.Forms.Form_User_Data is Data : User_Access) is function Set_Form_Userptr (Frm : Form; - Data : User_Access) return C_Int; + Data : User_Access) return Eti_Error; pragma Import (C, Set_Form_Userptr, "set_form_userptr"); - Res : constant Eti_Error := Set_Form_Userptr (Frm, Data); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Userptr (Frm, Data)); end Set_User_Data; -- | -- | diff --git a/Ada95/src/terminal_interface-curses-forms.adb b/Ada95/src/terminal_interface-curses-forms.adb index 915ed58418e0..3ed053ae1b68 100644 --- a/Ada95/src/terminal_interface-curses-forms.adb +++ b/Ada95/src/terminal_interface-curses-forms.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,12 +35,11 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.28 $ --- $Date: 2011/03/22 23:37:32 $ +-- $Revision: 1.32 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; @@ -62,22 +61,6 @@ package body Terminal_Interface.Curses.Forms is -- | -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr; - function FOS_2_CInt is new - Ada.Unchecked_Conversion (Field_Option_Set, - C_Int); - - function CInt_2_FOS is new - Ada.Unchecked_Conversion (C_Int, - Field_Option_Set); - - function FrmOS_2_CInt is new - Ada.Unchecked_Conversion (Form_Option_Set, - C_Int); - - function CInt_2_FrmOS is new - Ada.Unchecked_Conversion (C_Int, - Form_Option_Set); - procedure Request_Name (Key : Form_Request_Code; Name : out String) is @@ -130,15 +113,11 @@ package body Terminal_Interface.Curses.Forms is -- | procedure Delete (Fld : in out Field) is - function Free_Field (Fld : Field) return C_Int; + function Free_Field (Fld : Field) return Eti_Error; pragma Import (C, Free_Field, "free_field"); - Res : Eti_Error; begin - Res := Free_Field (Fld); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Free_Field (Fld)); Fld := Null_Field; end Delete; -- | @@ -194,16 +173,12 @@ package body Terminal_Interface.Curses.Forms is Just : Field_Justification := None) is function Set_Field_Just (Fld : Field; - Just : C_Int) return C_Int; + Just : C_Int) return Eti_Error; pragma Import (C, Set_Field_Just, "set_field_just"); - Res : constant Eti_Error := - Set_Field_Just (Fld, - C_Int (Field_Justification'Pos (Just))); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Just (Fld, + C_Int (Field_Justification'Pos (Just)))); end Set_Justification; -- | -- | @@ -227,22 +202,14 @@ package body Terminal_Interface.Curses.Forms is Buffer : Buffer_Number := Buffer_Number'First; Str : String) is - type Char_Ptr is access all Interfaces.C.char; function Set_Fld_Buffer (Fld : Field; Bufnum : C_Int; - S : Char_Ptr) - return C_Int; + S : char_array) + return Eti_Error; pragma Import (C, Set_Fld_Buffer, "set_field_buffer"); - Txt : char_array (0 .. Str'Length); - Len : size_t; - Res : Eti_Error; begin - To_C (Str, Txt, Len); - Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Fld_Buffer (Fld, C_Int (Buffer), To_C (Str))); end Set_Buffer; -- | -- | @@ -276,12 +243,11 @@ package body Terminal_Interface.Curses.Forms is Status : Boolean := True) is function Set_Fld_Status (Fld : Field; - St : C_Int) return C_Int; + St : C_Int) return Eti_Error; pragma Import (C, Set_Fld_Status, "set_field_status"); - Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status)); begin - if Res /= E_Ok then + if Set_Fld_Status (Fld, Boolean'Pos (Status)) /= E_Ok then raise Form_Exception; end if; end Set_Status; @@ -308,14 +274,11 @@ package body Terminal_Interface.Curses.Forms is Max : Natural := 0) is function Set_Field_Max (Fld : Field; - M : C_Int) return C_Int; + M : C_Int) return Eti_Error; pragma Import (C, Set_Field_Max, "set_max_field"); - Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Max (Fld, C_Int (Max))); end Set_Maximum_Size; -- | -- |===================================================================== @@ -328,16 +291,11 @@ package body Terminal_Interface.Curses.Forms is Options : Field_Option_Set) is function Set_Field_Opts (Fld : Field; - Opt : C_Int) return C_Int; + Opt : Field_Option_Set) return Eti_Error; pragma Import (C, Set_Field_Opts, "set_field_opts"); - Opt : constant C_Int := FOS_2_CInt (Options); - Res : Eti_Error; begin - Res := Set_Field_Opts (Fld, Opt); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Opts (Fld, Options)); end Set_Options; -- | -- | @@ -347,22 +305,17 @@ package body Terminal_Interface.Curses.Forms is On : Boolean := True) is function Field_Opts_On (Fld : Field; - Opt : C_Int) return C_Int; + Opt : Field_Option_Set) return Eti_Error; pragma Import (C, Field_Opts_On, "field_opts_on"); function Field_Opts_Off (Fld : Field; - Opt : C_Int) return C_Int; + Opt : Field_Option_Set) return Eti_Error; pragma Import (C, Field_Opts_Off, "field_opts_off"); - Err : Eti_Error; - Opt : constant C_Int := FOS_2_CInt (Options); begin if On then - Err := Field_Opts_On (Fld, Opt); + Eti_Exception (Field_Opts_On (Fld, Options)); else - Err := Field_Opts_Off (Fld, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Field_Opts_Off (Fld, Options)); end if; end Switch_Options; -- | @@ -371,12 +324,11 @@ package body Terminal_Interface.Curses.Forms is procedure Get_Options (Fld : Field; Options : out Field_Option_Set) is - function Field_Opts (Fld : Field) return C_Int; + function Field_Opts (Fld : Field) return Field_Option_Set; pragma Import (C, Field_Opts, "field_opts"); - Res : constant C_Int := Field_Opts (Fld); begin - Options := CInt_2_FOS (Res); + Options := Field_Opts (Fld); end Get_Options; -- | -- | @@ -402,18 +354,13 @@ package body Terminal_Interface.Curses.Forms is Color : Color_Pair := Color_Pair'First) is function Set_Field_Fore (Fld : Field; - Attr : C_Chtype) return C_Int; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Field_Fore, "set_field_fore"); - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Fore); - Res : constant Eti_Error := - Set_Field_Fore (Fld, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Fore (Fld, (Ch => Character'First, + Color => Color, + Attr => Fore))); end Set_Foreground; -- | -- | @@ -421,21 +368,21 @@ package body Terminal_Interface.Curses.Forms is procedure Foreground (Fld : Field; Fore : out Character_Attribute_Set) is - function Field_Fore (Fld : Field) return C_Chtype; + function Field_Fore (Fld : Field) return Attributed_Character; pragma Import (C, Field_Fore, "field_fore"); begin - Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr; + Fore := Field_Fore (Fld).Attr; end Foreground; procedure Foreground (Fld : Field; Fore : out Character_Attribute_Set; Color : out Color_Pair) is - function Field_Fore (Fld : Field) return C_Chtype; + function Field_Fore (Fld : Field) return Attributed_Character; pragma Import (C, Field_Fore, "field_fore"); begin - Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr; - Color := Chtype_To_AttrChar (Field_Fore (Fld)).Color; + Fore := Field_Fore (Fld).Attr; + Color := Field_Fore (Fld).Color; end Foreground; -- | -- | @@ -446,18 +393,13 @@ package body Terminal_Interface.Curses.Forms is Color : Color_Pair := Color_Pair'First) is function Set_Field_Back (Fld : Field; - Attr : C_Chtype) return C_Int; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Field_Back, "set_field_back"); - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Back); - Res : constant Eti_Error := - Set_Field_Back (Fld, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Back (Fld, (Ch => Character'First, + Color => Color, + Attr => Back))); end Set_Background; -- | -- | @@ -465,21 +407,21 @@ package body Terminal_Interface.Curses.Forms is procedure Background (Fld : Field; Back : out Character_Attribute_Set) is - function Field_Back (Fld : Field) return C_Chtype; + function Field_Back (Fld : Field) return Attributed_Character; pragma Import (C, Field_Back, "field_back"); begin - Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr; + Back := Field_Back (Fld).Attr; end Background; procedure Background (Fld : Field; Back : out Character_Attribute_Set; Color : out Color_Pair) is - function Field_Back (Fld : Field) return C_Chtype; + function Field_Back (Fld : Field) return Attributed_Character; pragma Import (C, Field_Back, "field_back"); begin - Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr; - Color := Chtype_To_AttrChar (Field_Back (Fld)).Color; + Back := Field_Back (Fld).Attr; + Color := Field_Back (Fld).Color; end Background; -- | -- | @@ -488,15 +430,12 @@ package body Terminal_Interface.Curses.Forms is Pad : Character := Space) is function Set_Field_Pad (Fld : Field; - Ch : C_Int) return C_Int; + Ch : C_Int) return Eti_Error; pragma Import (C, Set_Field_Pad, "set_field_pad"); - Res : constant Eti_Error := Set_Field_Pad (Fld, - C_Int (Character'Pos (Pad))); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Pad (Fld, + C_Int (Character'Pos (Pad)))); end Set_Pad_Character; -- | -- | @@ -527,25 +466,21 @@ package body Terminal_Interface.Curses.Forms is type C_Int_Access is access all C_Int; function Fld_Info (Fld : Field; L, C, Fr, Fc, Os, Ab : C_Int_Access) - return C_Int; + return Eti_Error; pragma Import (C, Fld_Info, "field_info"); L, C, Fr, Fc, Os, Ab : aliased C_Int; - Res : constant Eti_Error := Fld_Info (Fld, - L'Access, C'Access, - Fr'Access, Fc'Access, - Os'Access, Ab'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - else - Lines := Line_Count (L); - Columns := Column_Count (C); - First_Row := Line_Position (Fr); - First_Column := Column_Position (Fc); - Off_Screen := Natural (Os); - Additional_Buffers := Buffer_Number (Ab); - end if; + Eti_Exception (Fld_Info (Fld, + L'Access, C'Access, + Fr'Access, Fc'Access, + Os'Access, Ab'Access)); + Lines := Line_Count (L); + Columns := Column_Count (C); + First_Row := Line_Position (Fr); + First_Column := Column_Position (Fc); + Off_Screen := Natural (Os); + Additional_Buffers := Buffer_Number (Ab); end Info; -- | -- | @@ -556,21 +491,17 @@ package body Terminal_Interface.Curses.Forms is Max : out Natural) is type C_Int_Access is access all C_Int; - function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int; + function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return Eti_Error; pragma Import (C, Dyn_Info, "dynamic_field_info"); L, C, M : aliased C_Int; - Res : constant Eti_Error := Dyn_Info (Fld, - L'Access, C'Access, - M'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - else - Lines := Line_Count (L); - Columns := Column_Count (C); - Max := Natural (M); - end if; + Eti_Exception (Dyn_Info (Fld, + L'Access, C'Access, + M'Access)); + Lines := Line_Count (L); + Columns := Column_Count (C); + Max := Natural (M); end Dynamic_Info; -- | -- |===================================================================== @@ -583,14 +514,11 @@ package body Terminal_Interface.Curses.Forms is Win : Window) is function Set_Form_Win (Frm : Form; - Win : Window) return C_Int; + Win : Window) return Eti_Error; pragma Import (C, Set_Form_Win, "set_form_win"); - Res : constant Eti_Error := Set_Form_Win (Frm, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Win (Frm, Win)); end Set_Window; -- | -- | @@ -611,14 +539,11 @@ package body Terminal_Interface.Curses.Forms is Win : Window) is function Set_Form_Sub (Frm : Form; - Win : Window) return C_Int; + Win : Window) return Eti_Error; pragma Import (C, Set_Form_Sub, "set_form_sub"); - Res : constant Eti_Error := Set_Form_Sub (Frm, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Sub (Frm, Win)); end Set_Sub_Window; -- | -- | @@ -640,16 +565,13 @@ package body Terminal_Interface.Curses.Forms is Columns : out Column_Count) is type C_Int_Access is access all C_Int; - function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int; + function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return Eti_Error; pragma Import (C, M_Scale, "scale_form"); X, Y : aliased C_Int; - Res : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - Lines := Line_Count (Y); + Eti_Exception (M_Scale (Frm, Y'Access, X'Access)); + Lines := Line_Count (Y); Columns := Column_Count (X); end Scale; -- | @@ -663,14 +585,11 @@ package body Terminal_Interface.Curses.Forms is Proc : Form_Hook_Function) is function Set_Field_Init (Frm : Form; - Proc : Form_Hook_Function) return C_Int; + Proc : Form_Hook_Function) return Eti_Error; pragma Import (C, Set_Field_Init, "set_field_init"); - Res : constant Eti_Error := Set_Field_Init (Frm, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Init (Frm, Proc)); end Set_Field_Init_Hook; -- | -- | @@ -679,14 +598,11 @@ package body Terminal_Interface.Curses.Forms is Proc : Form_Hook_Function) is function Set_Field_Term (Frm : Form; - Proc : Form_Hook_Function) return C_Int; + Proc : Form_Hook_Function) return Eti_Error; pragma Import (C, Set_Field_Term, "set_field_term"); - Res : constant Eti_Error := Set_Field_Term (Frm, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Field_Term (Frm, Proc)); end Set_Field_Term_Hook; -- | -- | @@ -695,14 +611,11 @@ package body Terminal_Interface.Curses.Forms is Proc : Form_Hook_Function) is function Set_Form_Init (Frm : Form; - Proc : Form_Hook_Function) return C_Int; + Proc : Form_Hook_Function) return Eti_Error; pragma Import (C, Set_Form_Init, "set_form_init"); - Res : constant Eti_Error := Set_Form_Init (Frm, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Init (Frm, Proc)); end Set_Form_Init_Hook; -- | -- | @@ -711,14 +624,11 @@ package body Terminal_Interface.Curses.Forms is Proc : Form_Hook_Function) is function Set_Form_Term (Frm : Form; - Proc : Form_Hook_Function) return C_Int; + Proc : Form_Hook_Function) return Eti_Error; pragma Import (C, Set_Form_Term, "set_form_term"); - Res : constant Eti_Error := Set_Form_Term (Frm, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Term (Frm, Proc)); end Set_Form_Term_Hook; -- | -- |===================================================================== @@ -731,19 +641,15 @@ package body Terminal_Interface.Curses.Forms is Flds : Field_Array_Access) is function Set_Frm_Fields (Frm : Form; - Items : System.Address) return C_Int; + Items : System.Address) return Eti_Error; pragma Import (C, Set_Frm_Fields, "set_form_fields"); - Res : Eti_Error; begin pragma Assert (Flds.all (Flds'Last) = Null_Field); if Flds.all (Flds'Last) /= Null_Field then raise Form_Exception; else - Res := Set_Frm_Fields (Frm, Flds.all (Flds'First)'Address); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Frm_Fields (Frm, Flds.all (Flds'First)'Address)); end if; end Redefine; -- | @@ -783,14 +689,11 @@ package body Terminal_Interface.Curses.Forms is Line : Line_Position; Column : Column_Position) is - function Move (Fld : Field; L, C : C_Int) return C_Int; + function Move (Fld : Field; L, C : C_Int) return Eti_Error; pragma Import (C, Move, "move_field"); - Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Move (Fld, C_Int (Line), C_Int (Column))); end Move; -- | -- |===================================================================== @@ -822,14 +725,11 @@ package body Terminal_Interface.Curses.Forms is -- | procedure Delete (Frm : in out Form) is - function Free (Frm : Form) return C_Int; + function Free (Frm : Form) return Eti_Error; pragma Import (C, Free, "free_form"); - Res : constant Eti_Error := Free (Frm); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Free (Frm)); Frm := Null_Form; end Delete; -- | @@ -843,16 +743,11 @@ package body Terminal_Interface.Curses.Forms is Options : Form_Option_Set) is function Set_Form_Opts (Frm : Form; - Opt : C_Int) return C_Int; + Opt : Form_Option_Set) return Eti_Error; pragma Import (C, Set_Form_Opts, "set_form_opts"); - Opt : constant C_Int := FrmOS_2_CInt (Options); - Res : Eti_Error; begin - Res := Set_Form_Opts (Frm, Opt); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Form_Opts (Frm, Options)); end Set_Options; -- | -- | @@ -862,22 +757,17 @@ package body Terminal_Interface.Curses.Forms is On : Boolean := True) is function Form_Opts_On (Frm : Form; - Opt : C_Int) return C_Int; + Opt : Form_Option_Set) return Eti_Error; pragma Import (C, Form_Opts_On, "form_opts_on"); function Form_Opts_Off (Frm : Form; - Opt : C_Int) return C_Int; + Opt : Form_Option_Set) return Eti_Error; pragma Import (C, Form_Opts_Off, "form_opts_off"); - Err : Eti_Error; - Opt : constant C_Int := FrmOS_2_CInt (Options); begin if On then - Err := Form_Opts_On (Frm, Opt); + Eti_Exception (Form_Opts_On (Frm, Options)); else - Err := Form_Opts_Off (Frm, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Form_Opts_Off (Frm, Options)); end if; end Switch_Options; -- | @@ -886,12 +776,11 @@ package body Terminal_Interface.Curses.Forms is procedure Get_Options (Frm : Form; Options : out Form_Option_Set) is - function Form_Opts (Frm : Form) return C_Int; + function Form_Opts (Frm : Form) return Form_Option_Set; pragma Import (C, Form_Opts, "form_opts"); - Res : constant C_Int := Form_Opts (Frm); begin - Options := CInt_2_FrmOS (Res); + Options := Form_Opts (Frm); end Get_Options; -- | -- | @@ -913,20 +802,16 @@ package body Terminal_Interface.Curses.Forms is procedure Post (Frm : Form; Post : Boolean := True) is - function M_Post (Frm : Form) return C_Int; + function M_Post (Frm : Form) return Eti_Error; pragma Import (C, M_Post, "post_form"); - function M_Unpost (Frm : Form) return C_Int; + function M_Unpost (Frm : Form) return Eti_Error; pragma Import (C, M_Unpost, "unpost_form"); - Res : Eti_Error; begin if Post then - Res := M_Post (Frm); + Eti_Exception (M_Post (Frm)); else - Res := M_Unpost (Frm); - end if; - if Res /= E_Ok then - Eti_Exception (Res); + Eti_Exception (M_Unpost (Frm)); end if; end Post; -- | @@ -938,14 +823,11 @@ package body Terminal_Interface.Curses.Forms is -- | procedure Position_Cursor (Frm : Form) is - function Pos_Form_Cursor (Frm : Form) return C_Int; + function Pos_Form_Cursor (Frm : Form) return Eti_Error; pragma Import (C, Pos_Form_Cursor, "pos_form_cursor"); - Res : constant Eti_Error := Pos_Form_Cursor (Frm); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Pos_Form_Cursor (Frm)); end Position_Cursor; -- | -- |===================================================================== @@ -993,25 +875,22 @@ package body Terminal_Interface.Curses.Forms is function Driver (Frm : Form; Key : Key_Code) return Driver_Result is - function Frm_Driver (Frm : Form; Key : C_Int) return C_Int; + function Frm_Driver (Frm : Form; Key : C_Int) return Eti_Error; pragma Import (C, Frm_Driver, "form_driver"); R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key)); begin - if R /= E_Ok then - if R = E_Unknown_Command then + case R is + when E_Unknown_Command => return Unknown_Request; - elsif R = E_Invalid_Field then + when E_Invalid_Field => return Invalid_Field; - elsif R = E_Request_Denied then + when E_Request_Denied => return Request_Denied; - else + when others => Eti_Exception (R); return Form_Ok; - end if; - else - return Form_Ok; - end if; + end case; end Driver; -- | -- |===================================================================== @@ -1023,14 +902,11 @@ package body Terminal_Interface.Curses.Forms is procedure Set_Current (Frm : Form; Fld : Field) is - function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int; + function Set_Current_Fld (Frm : Form; Fld : Field) return Eti_Error; pragma Import (C, Set_Current_Fld, "set_current_field"); - Res : constant Eti_Error := Set_Current_Fld (Frm, Fld); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Current_Fld (Frm, Fld)); end Set_Current; -- | -- | @@ -1053,14 +929,11 @@ package body Terminal_Interface.Curses.Forms is procedure Set_Page (Frm : Form; Page : Page_Number := Page_Number'First) is - function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int; + function Set_Frm_Page (Frm : Form; Pg : C_Int) return Eti_Error; pragma Import (C, Set_Frm_Page, "set_form_page"); - Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Frm_Page (Frm, C_Int (Page))); end Set_Page; -- | -- | @@ -1102,14 +975,11 @@ package body Terminal_Interface.Curses.Forms is procedure Set_New_Page (Fld : Field; New_Page : Boolean := True) is - function Set_Page (Fld : Field; Flg : C_Int) return C_Int; + function Set_Page (Fld : Field; Flg : C_Int) return Eti_Error; pragma Import (C, Set_Page, "set_new_page"); - Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Page (Fld, Boolean'Pos (New_Page))); end Set_New_Page; -- | -- | diff --git a/Ada95/src/terminal_interface-curses-menus-item_user_data.adb b/Ada95/src/terminal_interface-curses-menus-item_user_data.adb index eb06d096dfb2..5135c20d7fce 100644 --- a/Ada95/src/terminal_interface-curses-menus-item_user_data.adb +++ b/Ada95/src/terminal_interface-curses-menus-item_user_data.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,28 +35,22 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.12 $ +-- $Revision: 1.15 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ -with Interfaces.C; with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; package body Terminal_Interface.Curses.Menus.Item_User_Data is - use type Interfaces.C.int; - procedure Set_User_Data (Itm : Item; Data : User_Access) is function Set_Item_Userptr (Itm : Item; - Addr : User_Access) return C_Int; + Addr : User_Access) return Eti_Error; pragma Import (C, Set_Item_Userptr, "set_item_userptr"); - Res : constant Eti_Error := Set_Item_Userptr (Itm, Data); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Userptr (Itm, Data)); end Set_User_Data; function Get_User_Data (Itm : Item) return User_Access diff --git a/Ada95/src/terminal_interface-curses-menus-menu_user_data.adb b/Ada95/src/terminal_interface-curses-menus-menu_user_data.adb index 7d66a8c052ee..e8e297ee915b 100644 --- a/Ada95/src/terminal_interface-curses-menus-menu_user_data.adb +++ b/Ada95/src/terminal_interface-curses-menus-menu_user_data.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2003,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,27 +35,23 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.13 $ +-- $Revision: 1.16 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; package body Terminal_Interface.Curses.Menus.Menu_User_Data is - use type Interfaces.C.int; - procedure Set_User_Data (Men : Menu; Data : User_Access) is function Set_Menu_Userptr (Men : Menu; - Data : User_Access) return C_Int; + Data : User_Access) return Eti_Error; pragma Import (C, Set_Menu_Userptr, "set_menu_userptr"); - Res : constant Eti_Error := Set_Menu_Userptr (Men, Data); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Userptr (Men, Data)); + end Set_User_Data; function Get_User_Data (Men : Menu) return User_Access diff --git a/Ada95/src/terminal_interface-curses-menus.adb b/Ada95/src/terminal_interface-curses-menus.adb index a7dca07c2876..fc840e2a978f 100644 --- a/Ada95/src/terminal_interface-curses-menus.adb +++ b/Ada95/src/terminal_interface-curses-menus.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.28 $ --- $Date: 2011/03/22 23:38:12 $ +-- $Revision: 1.33 $ +-- $Date: 2018/07/07 23:36:44 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; @@ -46,33 +46,14 @@ with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C.Pointers; -with Ada.Unchecked_Conversion; - package body Terminal_Interface.Curses.Menus is type C_Item_Array is array (Natural range <>) of aliased Item; package I_Array is new Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item); - use type System.Bit_Order; subtype chars_ptr is Interfaces.C.Strings.chars_ptr; - function MOS_2_CInt is new - Ada.Unchecked_Conversion (Menu_Option_Set, - C_Int); - - function CInt_2_MOS is new - Ada.Unchecked_Conversion (C_Int, - Menu_Option_Set); - - function IOS_2_CInt is new - Ada.Unchecked_Conversion (Item_Option_Set, - C_Int); - - function CInt_2_IOS is new - Ada.Unchecked_Conversion (C_Int, - Item_Option_Set); - ------------------------------------------------------------------------------ procedure Request_Name (Key : Menu_Request_Code; Name : out String) @@ -128,10 +109,9 @@ package body Terminal_Interface.Curses.Menus is function Itemname (Itm : Item) return chars_ptr; pragma Import (C, Itemname, "item_name"); - function Freeitem (Itm : Item) return C_Int; + function Freeitem (Itm : Item) return Eti_Error; pragma Import (C, Freeitem, "free_item"); - Res : Eti_Error; Ptr : chars_ptr; begin Ptr := Descname (Itm); @@ -142,10 +122,7 @@ package body Terminal_Interface.Curses.Menus is if Ptr /= Null_Ptr then Interfaces.C.Strings.Free (Ptr); end if; - Res := Freeitem (Itm); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Freeitem (Itm)); Itm := Null_Item; end Delete; ------------------------------------------------------------------------------- @@ -153,14 +130,11 @@ package body Terminal_Interface.Curses.Menus is Value : Boolean := True) is function Set_Item_Val (Itm : Item; - Val : C_Int) return C_Int; + Val : C_Int) return Eti_Error; pragma Import (C, Set_Item_Val, "set_item_value"); - Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Val (Itm, Boolean'Pos (Value))); end Set_Value; function Value (Itm : Item) return Boolean @@ -192,16 +166,11 @@ package body Terminal_Interface.Curses.Menus is Options : Item_Option_Set) is function Set_Item_Opts (Itm : Item; - Opt : C_Int) return C_Int; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Set_Item_Opts, "set_item_opts"); - Opt : constant C_Int := IOS_2_CInt (Options); - Res : Eti_Error; begin - Res := Set_Item_Opts (Itm, Opt); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Opts (Itm, Options)); end Set_Options; procedure Switch_Options (Itm : Item; @@ -209,34 +178,28 @@ package body Terminal_Interface.Curses.Menus is On : Boolean := True) is function Item_Opts_On (Itm : Item; - Opt : C_Int) return C_Int; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Item_Opts_On, "item_opts_on"); function Item_Opts_Off (Itm : Item; - Opt : C_Int) return C_Int; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Item_Opts_Off, "item_opts_off"); - Opt : constant C_Int := IOS_2_CInt (Options); - Err : Eti_Error; begin if On then - Err := Item_Opts_On (Itm, Opt); + Eti_Exception (Item_Opts_On (Itm, Options)); else - Err := Item_Opts_Off (Itm, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Item_Opts_Off (Itm, Options)); end if; end Switch_Options; procedure Get_Options (Itm : Item; Options : out Item_Option_Set) is - function Item_Opts (Itm : Item) return C_Int; + function Item_Opts (Itm : Item) return Item_Option_Set; pragma Import (C, Item_Opts, "item_opts"); - Res : constant C_Int := Item_Opts (Itm); begin - Options := CInt_2_IOS (Res); + Options := Item_Opts (Itm); end Get_Options; function Get_Options (Itm : Item := Null_Item) return Item_Option_Set @@ -285,14 +248,11 @@ package body Terminal_Interface.Curses.Menus is Itm : Item) is function Set_Curr_Item (Men : Menu; - Itm : Item) return C_Int; + Itm : Item) return Eti_Error; pragma Import (C, Set_Curr_Item, "set_current_item"); - Res : constant Eti_Error := Set_Curr_Item (Men, Itm); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Curr_Item (Men, Itm)); end Set_Current; function Current (Men : Menu) return Item @@ -312,14 +272,11 @@ package body Terminal_Interface.Curses.Menus is Line : Line_Position) is function Set_Toprow (Men : Menu; - Line : C_Int) return C_Int; + Line : C_Int) return Eti_Error; pragma Import (C, Set_Toprow, "set_top_row"); - Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Toprow (Men, C_Int (Line))); end Set_Top_Row; function Top_Row (Men : Menu) return Line_Position @@ -351,20 +308,16 @@ package body Terminal_Interface.Curses.Menus is procedure Post (Men : Menu; Post : Boolean := True) is - function M_Post (Men : Menu) return C_Int; + function M_Post (Men : Menu) return Eti_Error; pragma Import (C, M_Post, "post_menu"); - function M_Unpost (Men : Menu) return C_Int; + function M_Unpost (Men : Menu) return Eti_Error; pragma Import (C, M_Unpost, "unpost_menu"); - Res : Eti_Error; begin if Post then - Res := M_Post (Men); + Eti_Exception (M_Post (Men)); else - Res := M_Unpost (Men); - end if; - if Res /= E_Ok then - Eti_Exception (Res); + Eti_Exception (M_Unpost (Men)); end if; end Post; ------------------------------------------------------------------------------- @@ -372,16 +325,11 @@ package body Terminal_Interface.Curses.Menus is Options : Menu_Option_Set) is function Set_Menu_Opts (Men : Menu; - Opt : C_Int) return C_Int; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Set_Menu_Opts, "set_menu_opts"); - Opt : constant C_Int := MOS_2_CInt (Options); - Res : Eti_Error; begin - Res := Set_Menu_Opts (Men, Opt); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Opts (Men, Options)); end Set_Options; procedure Switch_Options (Men : Menu; @@ -389,34 +337,28 @@ package body Terminal_Interface.Curses.Menus is On : Boolean := True) is function Menu_Opts_On (Men : Menu; - Opt : C_Int) return C_Int; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Menu_Opts_On, "menu_opts_on"); function Menu_Opts_Off (Men : Menu; - Opt : C_Int) return C_Int; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Menu_Opts_Off, "menu_opts_off"); - Opt : constant C_Int := MOS_2_CInt (Options); - Err : Eti_Error; begin if On then - Err := Menu_Opts_On (Men, Opt); + Eti_Exception (Menu_Opts_On (Men, Options)); else - Err := Menu_Opts_Off (Men, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Menu_Opts_Off (Men, Options)); end if; end Switch_Options; procedure Get_Options (Men : Menu; Options : out Menu_Option_Set) is - function Menu_Opts (Men : Menu) return C_Int; + function Menu_Opts (Men : Menu) return Menu_Option_Set; pragma Import (C, Menu_Opts, "menu_opts"); - Res : constant C_Int := Menu_Opts (Men); begin - Options := CInt_2_MOS (Res); + Options := Menu_Opts (Men); end Get_Options; function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set @@ -431,14 +373,11 @@ package body Terminal_Interface.Curses.Menus is Win : Window) is function Set_Menu_Win (Men : Menu; - Win : Window) return C_Int; + Win : Window) return Eti_Error; pragma Import (C, Set_Menu_Win, "set_menu_win"); - Res : constant Eti_Error := Set_Menu_Win (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Win (Men, Win)); end Set_Window; function Get_Window (Men : Menu) return Window @@ -455,14 +394,11 @@ package body Terminal_Interface.Curses.Menus is Win : Window) is function Set_Menu_Sub (Men : Menu; - Win : Window) return C_Int; + Win : Window) return Eti_Error; pragma Import (C, Set_Menu_Sub, "set_menu_sub"); - Res : constant Eti_Error := Set_Menu_Sub (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Sub (Men, Win)); end Set_Sub_Window; function Get_Sub_Window (Men : Menu) return Window @@ -481,29 +417,23 @@ package body Terminal_Interface.Curses.Menus is is type C_Int_Access is access all C_Int; function M_Scale (Men : Menu; - Yp, Xp : C_Int_Access) return C_Int; + Yp, Xp : C_Int_Access) return Eti_Error; pragma Import (C, M_Scale, "scale_menu"); X, Y : aliased C_Int; - Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (M_Scale (Men, Y'Access, X'Access)); Lines := Line_Count (Y); Columns := Column_Count (X); end Scale; ------------------------------------------------------------------------------- procedure Position_Cursor (Men : Menu) is - function Pos_Menu_Cursor (Men : Menu) return C_Int; + function Pos_Menu_Cursor (Men : Menu) return Eti_Error; pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor"); - Res : constant Eti_Error := Pos_Menu_Cursor (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Pos_Menu_Cursor (Men)); end Position_Cursor; ------------------------------------------------------------------------------- @@ -512,18 +442,14 @@ package body Terminal_Interface.Curses.Menus is is type Char_Ptr is access all Interfaces.C.char; function Set_Mark (Men : Menu; - Mark : Char_Ptr) return C_Int; + Mark : Char_Ptr) return Eti_Error; pragma Import (C, Set_Mark, "set_menu_mark"); Txt : char_array (0 .. Mark'Length); Len : size_t; - Res : Eti_Error; begin To_C (Mark, Txt, Len); - Res := Set_Mark (Men, Txt (Txt'First)'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Mark (Men, Txt (Txt'First)'Access)); end Set_Mark; procedure Mark (Men : Menu; @@ -550,37 +476,34 @@ package body Terminal_Interface.Curses.Menus is Color : Color_Pair := Color_Pair'First) is function Set_Menu_Fore (Men : Menu; - Attr : C_Chtype) return C_Int; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Menu_Fore, "set_menu_fore"); Ch : constant Attributed_Character := (Ch => Character'First, Color => Color, Attr => Fore); - Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Fore (Men, Ch)); end Set_Foreground; procedure Foreground (Men : Menu; Fore : out Character_Attribute_Set) is - function Menu_Fore (Men : Menu) return C_Chtype; + function Menu_Fore (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; + Fore := Menu_Fore (Men).Attr; end Foreground; procedure Foreground (Men : Menu; Fore : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Fore (Men : Menu) return C_Chtype; + function Menu_Fore (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color; + Fore := Menu_Fore (Men).Attr; + Color := Menu_Fore (Men).Color; end Foreground; procedure Set_Background @@ -589,37 +512,34 @@ package body Terminal_Interface.Curses.Menus is Color : Color_Pair := Color_Pair'First) is function Set_Menu_Back (Men : Menu; - Attr : C_Chtype) return C_Int; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Menu_Back, "set_menu_back"); Ch : constant Attributed_Character := (Ch => Character'First, Color => Color, Attr => Back); - Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Back (Men, Ch)); end Set_Background; procedure Background (Men : Menu; Back : out Character_Attribute_Set) is - function Menu_Back (Men : Menu) return C_Chtype; + function Menu_Back (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; + Back := Menu_Back (Men).Attr; end Background; procedure Background (Men : Menu; Back : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Back (Men : Menu) return C_Chtype; + function Menu_Back (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Back (Men)).Color; + Back := Menu_Back (Men).Attr; + Color := Menu_Back (Men).Color; end Background; procedure Set_Grey (Men : Menu; @@ -627,53 +547,46 @@ package body Terminal_Interface.Curses.Menus is Color : Color_Pair := Color_Pair'First) is function Set_Menu_Grey (Men : Menu; - Attr : C_Chtype) return C_Int; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Menu_Grey, "set_menu_grey"); Ch : constant Attributed_Character := (Ch => Character'First, Color => Color, Attr => Grey); - Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Grey (Men, Ch)); end Set_Grey; procedure Grey (Men : Menu; Grey : out Character_Attribute_Set) is - function Menu_Grey (Men : Menu) return C_Chtype; + function Menu_Grey (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; + Grey := Menu_Grey (Men).Attr; end Grey; procedure Grey (Men : Menu; Grey : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Grey (Men : Menu) return C_Chtype; + function Menu_Grey (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color; + Grey := Menu_Grey (Men).Attr; + Color := Menu_Grey (Men).Color; end Grey; procedure Set_Pad_Character (Men : Menu; Pad : Character := Space) is function Set_Menu_Pad (Men : Menu; - Ch : C_Int) return C_Int; + Ch : C_Int) return Eti_Error; pragma Import (C, Set_Menu_Pad, "set_menu_pad"); - Res : constant Eti_Error := Set_Menu_Pad (Men, - C_Int (Character'Pos (Pad))); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Pad (Men, C_Int (Character'Pos (Pad)))); end Set_Pad_Character; procedure Pad_Character (Men : Menu; @@ -691,17 +604,14 @@ package body Terminal_Interface.Curses.Menus is Col : Column_Position := 0) is function Set_Spacing (Men : Menu; - D, R, C : C_Int) return C_Int; + D, R, C : C_Int) return Eti_Error; pragma Import (C, Set_Spacing, "set_menu_spacing"); - Res : constant Eti_Error := Set_Spacing (Men, - C_Int (Descr), - C_Int (Row), - C_Int (Col)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Spacing (Men, + C_Int (Descr), + C_Int (Row), + C_Int (Col))); end Set_Spacing; procedure Spacing (Men : Menu; @@ -711,22 +621,18 @@ package body Terminal_Interface.Curses.Menus is is type C_Int_Access is access all C_Int; function Get_Spacing (Men : Menu; - D, R, C : C_Int_Access) return C_Int; + D, R, C : C_Int_Access) return Eti_Error; pragma Import (C, Get_Spacing, "menu_spacing"); D, R, C : aliased C_Int; - Res : constant Eti_Error := Get_Spacing (Men, - D'Access, - R'Access, - C'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - else - Descr := Column_Position (D); - Row := Line_Position (R); - Col := Column_Position (C); - end if; + Eti_Exception (Get_Spacing (Men, + D'Access, + R'Access, + C'Access)); + Descr := Column_Position (D); + Row := Line_Position (R); + Col := Column_Position (C); end Spacing; ------------------------------------------------------------------------------- function Set_Pattern (Men : Menu; @@ -734,7 +640,7 @@ package body Terminal_Interface.Curses.Menus is is type Char_Ptr is access all Interfaces.C.char; function Set_Pattern (Men : Menu; - Pattern : Char_Ptr) return C_Int; + Pattern : Char_Ptr) return Eti_Error; pragma Import (C, Set_Pattern, "set_menu_pattern"); S : char_array (0 .. Text'Length); @@ -744,11 +650,11 @@ package body Terminal_Interface.Curses.Menus is To_C (Text, S, L); Res := Set_Pattern (Men, S (S'First)'Access); case Res is - when E_No_Match => return False; - when E_Ok => return True; + when E_No_Match => + return False; when others => Eti_Exception (Res); - return False; + return True; end case; end Set_Pattern; @@ -767,16 +673,14 @@ package body Terminal_Interface.Curses.Menus is is function Set_Menu_Fmt (Men : Menu; Lin : C_Int; - Col : C_Int) return C_Int; + Col : C_Int) return Eti_Error; pragma Import (C, Set_Menu_Fmt, "set_menu_format"); - Res : constant Eti_Error := Set_Menu_Fmt (Men, - C_Int (Lines), - C_Int (Columns)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Fmt (Men, + C_Int (Lines), + C_Int (Columns))); + end Set_Format; procedure Format (Men : Menu; @@ -785,74 +689,58 @@ package body Terminal_Interface.Curses.Menus is is type C_Int_Access is access all C_Int; function Menu_Fmt (Men : Menu; - Y, X : C_Int_Access) return C_Int; + Y, X : C_Int_Access) return Eti_Error; pragma Import (C, Menu_Fmt, "menu_format"); L, C : aliased C_Int; - Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); - else - Lines := Line_Count (L); - Columns := Column_Count (C); - end if; + Eti_Exception (Menu_Fmt (Men, L'Access, C'Access)); + Lines := Line_Count (L); + Columns := Column_Count (C); end Format; ------------------------------------------------------------------------------- procedure Set_Item_Init_Hook (Men : Menu; Proc : Menu_Hook_Function) is function Set_Item_Init (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Item_Init, "set_item_init"); - Res : constant Eti_Error := Set_Item_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Init (Men, Proc)); end Set_Item_Init_Hook; procedure Set_Item_Term_Hook (Men : Menu; Proc : Menu_Hook_Function) is function Set_Item_Term (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Item_Term, "set_item_term"); - Res : constant Eti_Error := Set_Item_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Term (Men, Proc)); end Set_Item_Term_Hook; procedure Set_Menu_Init_Hook (Men : Menu; Proc : Menu_Hook_Function) is function Set_Menu_Init (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Menu_Init, "set_menu_init"); - Res : constant Eti_Error := Set_Menu_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Init (Men, Proc)); end Set_Menu_Init_Hook; procedure Set_Menu_Term_Hook (Men : Menu; Proc : Menu_Hook_Function) is function Set_Menu_Term (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Menu_Term, "set_menu_term"); - Res : constant Eti_Error := Set_Menu_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Term (Men, Proc)); end Set_Menu_Term_Hook; function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function @@ -891,19 +779,15 @@ package body Terminal_Interface.Curses.Menus is Items : Item_Array_Access) is function Set_Items (Men : Menu; - Items : System.Address) return C_Int; + Items : System.Address) return Eti_Error; pragma Import (C, Set_Items, "set_menu_items"); - Res : Eti_Error; begin pragma Assert (Items.all (Items'Last) = Null_Item); if Items.all (Items'Last) /= Null_Item then raise Menu_Exception; else - Res := Set_Items (Men, Items.all'Address); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Items (Men, Items.all'Address)); end if; end Redefine; @@ -955,14 +839,11 @@ package body Terminal_Interface.Curses.Menus is procedure Delete (Men : in out Menu) is - function Free (Men : Menu) return C_Int; + function Free (Men : Menu) return Eti_Error; pragma Import (C, Free, "free_menu"); - Res : constant Eti_Error := Free (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Free (Men)); Men := Null_Menu; end Delete; @@ -971,22 +852,22 @@ package body Terminal_Interface.Curses.Menus is Key : Key_Code) return Driver_Result is function Driver (Men : Menu; - Key : C_Int) return C_Int; + Key : C_Int) return Eti_Error; pragma Import (C, Driver, "menu_driver"); R : constant Eti_Error := Driver (Men, C_Int (Key)); begin - if R /= E_Ok then - case R is - when E_Unknown_Command => return Unknown_Request; - when E_No_Match => return No_Match; - when E_Request_Denied | - E_Not_Selectable => return Request_Denied; - when others => - Eti_Exception (R); - end case; - end if; - return Menu_Ok; + case R is + when E_Unknown_Command => + return Unknown_Request; + when E_No_Match => + return No_Match; + when E_Request_Denied | E_Not_Selectable => + return Request_Denied; + when others => + Eti_Exception (R); + return Menu_Ok; + end case; end Driver; procedure Free (IA : in out Item_Array_Access; diff --git a/Ada95/src/terminal_interface-curses-mouse.adb b/Ada95/src/terminal_interface-curses-mouse.adb index 9b4032639308..49a440e64909 100644 --- a/Ada95/src/terminal_interface-curses-mouse.adb +++ b/Ada95/src/terminal_interface-curses-mouse.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2008,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2014,2018 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.24 $ --- $Date: 2009/12/26 17:38:58 $ +-- $Revision: 1.26 $ +-- $Date: 2018/07/07 23:35:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; @@ -45,8 +45,6 @@ use Interfaces; package body Terminal_Interface.Curses.Mouse is - use type System.Bit_Order; - function Has_Mouse return Boolean is function Mouse_Avail return C_Int; @@ -199,7 +197,8 @@ package body Terminal_Interface.Curses.Mouse is pragma Import (C, Wenclose, "wenclose"); begin if Wenclose (Win, C_Int (Event.Y), C_Int (Event.X)) - = Curses_Bool_False then + = Curses_Bool_False + then return False; else return True; diff --git a/Ada95/src/terminal_interface-curses-putwin.adb b/Ada95/src/terminal_interface-curses-putwin.adb index 986cd6b9bd6c..c5724d118705 100644 --- a/Ada95/src/terminal_interface-curses-putwin.adb +++ b/Ada95/src/terminal_interface-curses-putwin.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- Copyright (c) 2000,2003 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.3 $ +-- $Revision: 1.4 $ -- Binding Version 01.00 with Ada.Streams.Stream_IO.C_Streams; diff --git a/Ada95/src/terminal_interface-curses-putwin.ads b/Ada95/src/terminal_interface-curses-putwin.ads index d302bdcec452..24d05063e1cd 100644 --- a/Ada95/src/terminal_interface-curses-putwin.ads +++ b/Ada95/src/terminal_interface-curses-putwin.ads @@ -7,7 +7,7 @@ -- S P E C -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- Copyright (c) 2000,2003 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.3 $ +-- $Revision: 1.4 $ -- Binding Version 01.00 with Ada.Streams.Stream_IO; diff --git a/Ada95/src/terminal_interface-curses-termcap.ads b/Ada95/src/terminal_interface-curses-termcap.ads index dd01396e8b0b..e5f19f658e5d 100644 --- a/Ada95/src/terminal_interface-curses-termcap.ads +++ b/Ada95/src/terminal_interface-curses-termcap.ads @@ -7,7 +7,7 @@ -- S P E C -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- Copyright (c) 2000,2003 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.3 $ +-- $Revision: 1.4 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ diff --git a/Ada95/src/terminal_interface-curses-terminfo.ads b/Ada95/src/terminal_interface-curses-terminfo.ads index fb39bf1ed6f1..67f951d08f55 100644 --- a/Ada95/src/terminal_interface-curses-terminfo.ads +++ b/Ada95/src/terminal_interface-curses-terminfo.ads @@ -7,7 +7,7 @@ -- S P E C -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 2000 Free Software Foundation, Inc. -- +-- Copyright (c) 2000,2003 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,7 +35,7 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.3 $ +-- $Revision: 1.4 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ diff --git a/Ada95/src/terminal_interface-curses-text_io.adb b/Ada95/src/terminal_interface-curses-text_io.adb index e2ca27f208e7..85a4f44b637a 100644 --- a/Ada95/src/terminal_interface-curses-text_io.adb +++ b/Ada95/src/terminal_interface-curses-text_io.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.20 $ --- $Date: 2011/03/22 23:38:49 $ +-- $Revision: 1.22 $ +-- $Date: 2014/05/24 21:32:18 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ package body Terminal_Interface.Curses.Text_IO is @@ -205,7 +205,7 @@ package body Terminal_Interface.Curses.Text_IO is end if; Get_Cursor_Position (Win, Y1, X); - pragma Unreferenced (X); + pragma Warnings (Off, X); -- unreferenced N := Natural (To); N := N - 1; Y2 := Line_Position (N); if Y2 < Y1 then diff --git a/Ada95/src/terminal_interface-curses-trace.adb_p b/Ada95/src/terminal_interface-curses-trace.adb_p index d2117a4cef17..0dead37675ff 100644 --- a/Ada95/src/terminal_interface-curses-trace.adb_p +++ b/Ada95/src/terminal_interface-curses-trace.adb_p @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 2000-2004,2009 Free Software Foundation, Inc. -- +-- Copyright (c) 2000-2009,2014 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- @@ -35,60 +35,39 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.7 $ +-- $Revision: 1.11 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ #if ADA_TRACE then with Interfaces.C; use Interfaces.C; -with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; -with Ada.Unchecked_Conversion; #end if; package body Terminal_Interface.Curses.Trace is #if ADA_TRACE then - type C_TraceType is new C_UInt; - - function TraceAda_To_TraceC is new - Ada.Unchecked_Conversion (Source => Trace_Attribute_Set, - Target => C_TraceType); - procedure Trace_On (x : Trace_Attribute_Set) is - procedure traceC (y : C_TraceType); + procedure traceC (y : Trace_Attribute_Set); pragma Import (C, traceC, "trace"); begin - traceC (TraceAda_To_TraceC (x)); + traceC (x); end Trace_On; - -- 75. (12) A C function that takes a variable number of arguments can - -- correspond to several Ada subprograms, taking various specific - -- numbers and types of parameters. - procedure Trace_Put (str : String) is procedure tracef (format : char_array; s : char_array); pragma Import (C, tracef, "_traces"); - Txt : char_array (0 .. str'Length); - Length : size_t; - formatstr : constant String := "%s" & ASCII.NUL; - formattxt : char_array (0 .. formatstr'Length); + -- _traces() is defined in c_varargs_to_ada.h begin - To_C (formatstr, formattxt, Length); - To_C (str, Txt, Length); - tracef (formattxt, Txt); + tracef (To_C ("%s"), To_C (str)); end Trace_Put; #else procedure Trace_On (x : Trace_Attribute_Set) is -#if PRAGMA_UNREF - pragma Unreferenced (x); -#end if; + pragma Warnings (Off, x); -- unreferenced begin null; end Trace_On; procedure Trace_Put (str : String) is -#if PRAGMA_UNREF - pragma Unreferenced (str); -#end if; + pragma Warnings (Off, str); -- unreferenced begin null; end Trace_Put; |