This big commit: * Adds support to the FFI mechanism to map Algol 68 procedures returning strings to an equivalent C interface.
* Adds a new command-line option -fbuilding-libga68. * Adds support for having modules in libga68 implicitly invoked in user-written programs and modules. * Using the infrastructure agove, removes the compiler-generated glue to call the standard POSIX prelude shipped in libga68 to, instead, use the formal holes mechanism for FFI. * Adds posix.a68 to libga68. * Adds standard.a68 to libga68. Signed-off-by: Jose E. Marchesi <[email protected]> gcc/algol68/ChangeLog * a68-moids-misc.cc (a68_is_c_mode): Allow C formal holes for routines yielding strings. * a68-low-holes.cc (a68_wrap_formal_proc_hole): Support wrappers that yield strings. * a68.h: Remove a68_posix_* and a68_lower_posix* prototypes. * a68-low-posix.cc: Remove. * a68-imports.cc (a68_open_packet): Get argument filename. * Make-lang.in (ALGOL68_OBJS): Remove algol68/a68-low-posix.o. * a68-low-runtime.def: Remove POSIX_*. * lang.opt (-fcheck): Add new undocumented option -fbuilding-libga68. * a68-parser-prelude.cc (stand_transput): New function. (posix_prelude): Remove hardcoded additions to the top-level environment and use a68_extract_revelations instead. * a68-parser-extract.cc (a68_extract_revelation): Renamed from extract_revelation and made accessible externally. * a68-low.cc (a68_make_formal_hole_decl): Remove unneeded check. (lower_lude_decl): New function. (lower_module_text): Add calls to preludes and postludes of standard modules if not building libga68. (a68_lower_particular_program): Likewise. * a68-low-prelude.cc (a68_lower_posixargc): Remove. (a68_lower_posixargv): Likewise. (a68_lower_posixgetenv): Likewise. (a68_lower_posixputchar): Likewise. (a68_lower_posixputs): Likewise. (a68_lower_posixfconnect): Likewise. (a68_lower_posixfopen): Likewise. (a68_lower_posixfcreate): Likewise. (a68_lower_posixfclose): Likewise. (a68_lower_posixfsize): Likewise. (a68_lower_posixlseek): Likewise. (a68_lower_posixseekcur): Likewise. (a68_lower_posixseekend): Likewise. (a68_lower_posixseekset): Likewise. (a68_lower_posixstdinfiledes): Likewise. (a68_lower_posixstdoutfiledes): Likewise. (a68_lower_posixstderrfiledes): Likewise. (a68_lower_posixfileodefault): Likewise. (a68_lower_posixfileordwr): Likewise. (a68_lower_posixfileordonly): Likewise. (a68_lower_posixfileowronly): Likewise. (a68_lower_posixfileotrunc): Likewise. (a68_lower_posixerrno): Likewise. (a68_lower_posixexit): Likewise. (a68_lower_posixperror): Likewise. (a68_lower_posixstrerror): Likewise. (a68_lower_posixfputc): Likewise. (a68_lower_posixfputs): Likewise. (a68_lower_posixgetchar): Likewise. (a68_lower_posixfgetc): Likewise. (a68_lower_posixgets): Likewise. (a68_lower_posixfgets): Likewise. gcc/testsuite/ChangeLog * lib/algol68.exp (algol68_init): Add -I options to ALGOL68_UNDER_TEST so exports in libga68.{a,so} are found. * algol68/compile/warning-hidding-6.a68: Likewise. * algol68/compile/warning-hidding-5.a68: Use maxint instead of getchar to trigger the warning. * algol68/compile/error-nest-4.a68: Procedures yielding strings are now on in C formal holes. libga68/ChangeLog * posix.a68: New file. * standard.a68.in: Likewise. * ga68-posix.c (_libga68_stdin): Define. (_libga68_stdout): Likewise. (_libga68_stderr): Likewise. (_libga68_file_o_default): Likewise. (_libga68_file_o_rdonly): Likewise. (_libga68_file_o_rdwr): Likewise. (_libga68_file_o_trunc): Likewise. (_libga68_seek_cur): Likewise. (_libga68_seek_end): Likewise. (_libga68_seek_set): Likewise. (_libga68_posixstrerror): Update interface to new way of returning Algol 68 strings. (_libga68_posixargv): Likewise. (_libga68_posixfgets): Likewise. (_libga68_posixgets): Likewise. (_libga68_posixfopen): Use _libga68_file_o_default rather than FILE_O_DEFAULT. (_libga68_posixfopen): Ditto for other FILE_O_* values. * ga68.h: Update prototypes. * Makefile.am (libga68_la_LIBADD): Add standard.lo. (libga68_la_DEPENDENCIES): Likeise. (.a68.o): Pass -fbuilding-libga68. (.a68.lo): Likewise. (standard.a68): New rule. * Makefile.in: Regenerate. * transput.a68.in: Add Emacs -*- mode: a68 -*- comment. --- gcc/algol68/Make-lang.in | 1 - gcc/algol68/a68-imports.cc | 39 +- gcc/algol68/a68-low-holes.cc | 76 ++- gcc/algol68/a68-low-posix.cc | 556 ------------------ gcc/algol68/a68-low-prelude.cc | 293 --------- gcc/algol68/a68-low-runtime.def | 21 - gcc/algol68/a68-low.cc | 71 ++- gcc/algol68/a68-moids-misc.cc | 6 +- gcc/algol68/a68-parser-extract.cc | 46 +- gcc/algol68/a68-parser-prelude.cc | 95 +-- gcc/algol68/a68.h | 62 +- gcc/algol68/lang.opt | 3 + .../algol68/compile/error-nest-4.a68 | 2 +- .../algol68/compile/warning-hidding-5.a68 | 2 +- .../algol68/compile/warning-hidding-6.a68 | 2 +- gcc/testsuite/lib/algol68.exp | 2 +- libga68/Makefile.am | 13 +- libga68/Makefile.in | 13 +- libga68/ga68-posix.c | 59 +- libga68/ga68.h | 8 +- libga68/posix.a68 | 65 ++ libga68/standard.a68.in | 29 + libga68/transput.a68.in | 2 +- 23 files changed, 373 insertions(+), 1093 deletions(-) delete mode 100644 gcc/algol68/a68-low-posix.cc create mode 100644 libga68/posix.a68 create mode 100644 libga68/standard.a68.in diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in index 3a0f51b06a7..2d86cf22e17 100644 --- a/gcc/algol68/Make-lang.in +++ b/gcc/algol68/Make-lang.in @@ -105,7 +105,6 @@ ALGOL68_OBJS = algol68/a68-lang.o \ algol68/a68-low-reals.o \ algol68/a68-low-complex.o \ algol68/a68-low-bits.o \ - algol68/a68-low-posix.o \ algol68/a68-low-prelude.o \ algol68/a68-low-ranges.o \ algol68/a68-low-runtime.o \ diff --git a/gcc/algol68/a68-imports.cc b/gcc/algol68/a68-imports.cc index fe95ae35547..3a69fdee7a8 100644 --- a/gcc/algol68/a68-imports.cc +++ b/gcc/algol68/a68-imports.cc @@ -1366,10 +1366,14 @@ a68_decode_moifs (const char *data, size_t size, const char **errstr) } /* Get a moif with the exports for module named MODULE. If no exports can be - found then return NULL. */ + found then return NULL. + + If BASENAME is not NULL then it specifies the basefile of the file to open + for the module exports: BASENAME.o, libBASENAME.so, etc. If BASENAME is + NULL then the filename is derived from the module name. */ MOIF_T * -a68_open_packet (const char *module) +a68_open_packet (const char *module, const char *basename) { /* We may have a suitable moif already decoded for the requested module. If so, use it. */ @@ -1390,21 +1394,26 @@ a68_open_packet (const char *module) if (moif == NO_MOIF) { char *filename; - const char **pfilename = A68_MODULE_FILES->get (module); - if (pfilename == NULL) - { - /* Turn the module indicant in MODULE to lower-case. */ - filename = (char *) alloca (strlen (module) + 1); - size_t i = 0; - for (; i < strlen (module); i++) - filename[i] = TOLOWER (module[i]); - filename[i] = '\0'; - } + if (basename != NULL) + filename = xstrdup (basename); else { - size_t len = strlen (*pfilename) + 1; - filename = (char *) alloca (len); - memcpy (filename, *pfilename, len); + const char **pfilename = A68_MODULE_FILES->get (module); + if (pfilename == NULL) + { + /* Turn the module indicant in MODULE to lower-case. */ + filename = (char *) alloca (strlen (module) + 1); + size_t i = 0; + for (; i < strlen (module); i++) + filename[i] = TOLOWER (module[i]); + filename[i] = '\0'; + } + else + { + size_t len = strlen (*pfilename) + 1; + filename = (char *) alloca (len); + memcpy (filename, *pfilename, len); + } } /* Try to read exports data in a buffer. */ diff --git a/gcc/algol68/a68-low-holes.cc b/gcc/algol68/a68-low-holes.cc index eaf4ddfecb3..a1c5073c3b2 100644 --- a/gcc/algol68/a68-low-holes.cc +++ b/gcc/algol68/a68-low-holes.cc @@ -104,9 +104,13 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper) else wrapped_nargs += 1; } + if (SUB (m) == M_STRING) + wrapped_nargs += 2; /* Now build the type of the wrapped function. */ - + tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper)); + tree wrapped_ret_type = (SUB (m) == M_STRING + ? void_type_node : wrapper_ret_type); tree *wrapped_args_types = XALLOCAVEC (tree, wrapped_nargs); int nwrappedarg = 0; for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z)) @@ -123,11 +127,18 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper) } } - tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper)); - tree wrapped_type = build_function_type_array (wrapper_ret_type, + if (SUB (m) == M_STRING) + { + wrapped_args_types[nwrappedarg++] + = build_pointer_type (build_pointer_type (a68_char_type)); + wrapped_args_types[nwrappedarg++] + = build_pointer_type (size_type_node); + } + + tree wrapped_type = build_function_type_array (wrapped_ret_type, wrapped_nargs, wrapped_args_types); - + /* And a decl for the wrapped function. */ tree wrapped = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL, @@ -167,13 +178,56 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper) } DECL_ARGUMENTS (wrapper) = nreverse (DECL_ARGUMENTS (wrapper)); + tree body = NULL_TREE; a68_push_function_range (wrapper, wrapper_ret_type); - - /* We need a pointer to a function type. */ - if (!POINTER_TYPE_P (TREE_TYPE (wrapped))) - wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)), - wrapped); - - tree body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args); + { + /* Note how we need a pointer to a function type for the call. */ + if (!POINTER_TYPE_P (TREE_TYPE (wrapped))) + wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)), + wrapped); + if (SUB (m) == M_STRING + || (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING)) + { + a68_push_range (SUB (m)); + tree ptrchar_type = build_pointer_type (a68_char_type); + tree r = a68_lower_tmpvar ("r%", ptrchar_type, build_int_cst (ptrchar_type, 0)); + tree rlen = a68_lower_tmpvar ("rlen%", sizetype, size_int (0)); + TREE_ADDRESSABLE (r) = 1; + TREE_ADDRESSABLE (rlen) = 1; + + /* Add two additional arguments to the wrapped call if the wrapper + returns a string. */ + wrapped_args->quick_push (fold_build1 (ADDR_EXPR, + build_pointer_type (ptrchar_type), r)); + wrapped_args->quick_push (fold_build1 (ADDR_EXPR, + build_pointer_type (sizetype), rlen)); + + /* Call to the wrapped function. */ + tree call = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args); + a68_add_stmt (call); + + /* Build the result string. */ + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, rlen); + tree relems_size = fold_build2 (MULT_EXPR, sizetype, + rlen, size_in_bytes (a68_char_type)); + + + if (SUB (m) == M_STRING) + a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, + r, relems_size, &lower_bound, &upper_bound)); + else + { + /* Return a ref to string. */ + gcc_assert (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING); + a68_add_stmt (a68_row_malloc (M_STRING, 1 /* dim */, + r, relems_size, + &lower_bound, &upper_bound)); + } + body = a68_pop_range (); + } + else + body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args); + } a68_pop_function_range (body); } diff --git a/gcc/algol68/a68-low-posix.cc b/gcc/algol68/a68-low-posix.cc deleted file mode 100644 index c0fd947fdb4..00000000000 --- a/gcc/algol68/a68-low-posix.cc +++ /dev/null @@ -1,556 +0,0 @@ -/* Lowering routines for the POSIX prelude. - Copyright (C) 2025 Jose E. Marchesi. - - Written by Jose E. Marchesi. - - GCC is free software; you can redistribute it and/or modify it - under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3, or (at your option) - any later version. - - GCC is distributed in the hope that it will be useful, but WITHOUT - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY - or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public - License for more details. - - You should have received a copy of the GNU General Public License - along with GCC; see the file COPYING3. If not see - <http://www.gnu.org/licenses/>. */ - -#define INCLUDE_MEMORY -#include "config.h" -#include "system.h" -#include "coretypes.h" - -#include "tree.h" -#include "fold-const.h" -#include "diagnostic.h" -#include "langhooks.h" -#include "tm.h" -#include "function.h" -#include "cgraph.h" -#include "toplev.h" -#include "varasm.h" -#include "predict.h" -#include "stor-layout.h" -#include "tree-iterator.h" -#include "stringpool.h" -#include "print-tree.h" -#include "gimplify.h" -#include "dumpfile.h" -#include "convert.h" - -#include "a68.h" - -/* Number of command line arguments passed to the program. */ - -tree -a68_posix_argc (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_ARGC); -} - -/* Gets the Nth command line argument passed to the program. If N is out of - range the result is an empty string. */ - -tree -a68_posix_argv (void) -{ - static tree argv_fndecl; - - if (argv_fndecl == NULL_TREE) - { - argv_fndecl - = a68_low_toplevel_func_decl ("argv", - build_function_type_list (CTYPE (M_STRING), - a68_int_type, - NULL_TREE)); - announce_function (argv_fndecl); - - tree param = a68_low_func_param (argv_fndecl, "n", a68_int_type); - DECL_ARGUMENTS (argv_fndecl) = param; - - a68_push_function_range (argv_fndecl, CTYPE (M_STRING), - true /* top_level */); - - a68_push_range (M_STRING); - tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); - TREE_ADDRESSABLE (len) = 1; - - tree ptrtochar_type = build_pointer_type (a68_char_type); - tree elems = a68_lower_tmpvar ("elems%", ptrtochar_type, - a68_build_libcall (A68_LIBCALL_POSIX_ARGV, - ptrtochar_type, 2, - param, - fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), - len))); - tree lower_bound = ssize_int (1); - tree upper_bound = fold_convert (ssizetype, len); - tree elems_size = fold_build2 (MULT_EXPR, sizetype, - len, - size_in_bytes (a68_char_type)); - a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, - elems, elems_size, - &lower_bound, &upper_bound)); - tree body = a68_pop_range (); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (argv_fndecl)), - argv_fndecl); -} - -/* Gets the value of an environment variable, or an empty string if the - variable is not set. */ - -tree -a68_posix_getenv (void) -{ - static tree getenv_fndecl; - - if (getenv_fndecl == NULL_TREE) - { - getenv_fndecl - = a68_low_toplevel_func_decl ("getenv", - build_function_type_list (CTYPE (M_STRING), - CTYPE (M_STRING), - NULL_TREE)); - announce_function (getenv_fndecl); - - tree param = a68_low_func_param (getenv_fndecl, "varname", CTYPE (M_STRING)); - DECL_ARGUMENTS (getenv_fndecl) = param; - - a68_push_function_range (getenv_fndecl, CTYPE (M_STRING), - true /* top_level */); - - a68_push_range (M_STRING); - - tree varname = a68_lower_tmpvar ("varname%", CTYPE (M_STRING), - param); - - tree ptrtochar_type = build_pointer_type (a68_char_type); - tree convelems = a68_lower_tmpvar ("convelems%", ptrtochar_type, - build_int_cst (ptrtochar_type, 0)); - TREE_ADDRESSABLE (convelems) = 1; - tree convelemslen = a68_lower_tmpvar ("convelemslen%", sizetype, - size_int (0)); - TREE_ADDRESSABLE (convelemslen) = 1; - - tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETENV, - void_type_node, 5, - a68_multiple_elements (varname), - a68_multiple_num_elems (varname), - a68_multiple_stride (varname, size_zero_node), - fold_build1 (ADDR_EXPR, build_pointer_type (ptrtochar_type), - convelems), - fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), - convelemslen)); - a68_add_stmt (call); - tree lower_bound = ssize_int (1); - tree upper_bound = fold_convert (ssizetype, convelemslen); - tree convelems_size = fold_build2 (MULT_EXPR, sizetype, - convelemslen, - size_in_bytes (a68_char_type)); - a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, - convelems, convelems_size, - &lower_bound, &upper_bound)); - tree body = a68_pop_range (); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (getenv_fndecl)), - getenv_fndecl); -} - -tree -a68_posix_putchar (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_PUTCHAR); -} - -tree -a68_posix_puts (void) -{ - static tree puts_fndecl; - - if (puts_fndecl == NULL_TREE) - { - puts_fndecl - = a68_low_toplevel_func_decl ("puts", - build_function_type_list (void_type_node, - CTYPE (M_STRING), - NULL_TREE)); - announce_function (puts_fndecl); - - tree param = a68_low_func_param (puts_fndecl, "str", CTYPE (M_STRING)); - DECL_ARGUMENTS (puts_fndecl) = param; - - a68_push_function_range (puts_fndecl, void_type_node, - true /* top_level */); - - tree call = a68_build_libcall (A68_LIBCALL_POSIX_PUTS, - void_type_node, 3, - a68_multiple_elements (param), - a68_multiple_num_elems (param), - a68_multiple_stride (param, size_zero_node)); - a68_pop_function_range (call); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (puts_fndecl)), - puts_fndecl); -} - -tree -a68_posix_fconnect (void) -{ - static tree fconnect_fndecl; - - if (fconnect_fndecl == NULL_TREE) - { - fconnect_fndecl - = a68_low_toplevel_func_decl ("fconnect", - build_function_type_list (a68_int_type, - CTYPE (M_STRING), - a68_bits_type, - NULL_TREE)); - announce_function (fconnect_fndecl); - - tree host = a68_low_func_param (fconnect_fndecl, "host", CTYPE (M_STRING)); - tree port = a68_low_func_param (fconnect_fndecl, "port", a68_int_type); - DECL_ARGUMENTS (fconnect_fndecl) = chainon (host, port); - - a68_push_function_range (fconnect_fndecl, a68_int_type, - true /* top_level */); - - - tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCONNECT, - a68_int_type, 4, - a68_multiple_elements (host), - a68_multiple_num_elems (host), - a68_multiple_stride (host, size_zero_node), - port); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fconnect_fndecl)), - fconnect_fndecl); -} - -tree -a68_posix_fcreate (void) -{ - static tree fcreate_fndecl; - - if (fcreate_fndecl == NULL_TREE) - { - fcreate_fndecl - = a68_low_toplevel_func_decl ("fcreate", - build_function_type_list (a68_int_type, - CTYPE (M_STRING), - a68_bits_type, - NULL_TREE)); - announce_function (fcreate_fndecl); - - tree pathname = a68_low_func_param (fcreate_fndecl, "pathname", CTYPE (M_STRING)); - tree mode = a68_low_func_param (fcreate_fndecl, "mode", a68_int_type); - DECL_ARGUMENTS (fcreate_fndecl) = chainon (pathname, mode); - - a68_push_function_range (fcreate_fndecl, a68_int_type, - true /* top_level */); - - - tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCREATE, - a68_int_type, 4, - a68_multiple_elements (pathname), - a68_multiple_num_elems (pathname), - a68_multiple_stride (pathname, size_zero_node), - mode); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fcreate_fndecl)), - fcreate_fndecl); -} - -tree -a68_posix_fopen (void) -{ - static tree fopen_fndecl; - - if (fopen_fndecl == NULL_TREE) - { - fopen_fndecl - = a68_low_toplevel_func_decl ("fopen", - build_function_type_list (a68_int_type, - CTYPE (M_STRING), - a68_bits_type, - NULL_TREE)); - announce_function (fopen_fndecl); - - tree pathname = a68_low_func_param (fopen_fndecl, "pathname", CTYPE (M_STRING)); - tree flags = a68_low_func_param (fopen_fndecl, "flags", a68_int_type); - DECL_ARGUMENTS (fopen_fndecl) = chainon (pathname, flags); - - a68_push_function_range (fopen_fndecl, a68_int_type, - true /* top_level */); - - - tree body = a68_build_libcall (A68_LIBCALL_POSIX_FOPEN, - a68_int_type, 4, - a68_multiple_elements (pathname), - a68_multiple_num_elems (pathname), - a68_multiple_stride (pathname, size_zero_node), - flags); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fopen_fndecl)), - fopen_fndecl); -} - -tree -a68_posix_fclose (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_FCLOSE); -} - -tree -a68_posix_fsize (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_FSIZE); -} - -tree -a68_posix_lseek (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_LSEEK); -} - -tree -a68_posix_errno (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_ERRNO); -} - -tree -a68_posix_exit (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_EXIT); -} - -tree -a68_posix_perror (void) -{ - static tree perror_fndecl; - - if (perror_fndecl == NULL_TREE) - { - perror_fndecl - = a68_low_toplevel_func_decl ("perror", - build_function_type_list (void_type_node, - CTYPE (M_STRING), - NULL_TREE)); - announce_function (perror_fndecl); - - tree str = a68_low_func_param (perror_fndecl, "str", CTYPE (M_STRING)); - DECL_ARGUMENTS (perror_fndecl) = str; - - a68_push_function_range (perror_fndecl, void_type_node, - true /* top_level */); - - tree body = a68_build_libcall (A68_LIBCALL_POSIX_PERROR, - a68_int_type, 3, - a68_multiple_elements (str), - a68_multiple_num_elems (str), - a68_multiple_stride (str, size_zero_node)); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (perror_fndecl)), - perror_fndecl); -} - -tree -a68_posix_strerror (void) -{ - static tree strerror_fndecl; - - if (strerror_fndecl == NULL_TREE) - { - strerror_fndecl - = a68_low_toplevel_func_decl ("strerror", - build_function_type_list (CTYPE (M_STRING), - a68_int_type, - NULL_TREE)); - announce_function (strerror_fndecl); - - tree errnum = a68_low_func_param (strerror_fndecl, "errnum", a68_int_type); - DECL_ARGUMENTS (strerror_fndecl) = errnum; - - a68_push_function_range (strerror_fndecl, CTYPE (M_STRING), - true /* top_level */); - - tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); - TREE_ADDRESSABLE (len) = 1; - - tree call = a68_build_libcall (A68_LIBCALL_POSIX_STRERROR, - void_type_node, 2, - errnum, - fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); - tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); - - tree lower_bound = ssize_int (1); - tree upper_bound = fold_convert (ssizetype, len); - tree elems_size = fold_build2 (MULT_EXPR, sizetype, - len, size_in_bytes (a68_char_type)); - - tree body = a68_row_value (CTYPE (M_STRING), 1 /* dim */, - elems, elems_size, - &lower_bound, &upper_bound); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (strerror_fndecl)), - strerror_fndecl); -} - -tree -a68_posix_getchar (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_GETCHAR); -} - -tree -a68_posix_fgetc (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_FGETC); -} - -tree -a68_posix_fputc (void) -{ - return a68_get_libcall (A68_LIBCALL_POSIX_FPUTC); -} - -tree -a68_posix_fputs (void) -{ - static tree fputs_fndecl; - - if (fputs_fndecl == NULL_TREE) - { - fputs_fndecl - = a68_low_toplevel_func_decl ("fputs", - build_function_type_list (a68_int_type, - a68_int_type, - CTYPE (M_STRING), - NULL_TREE)); - announce_function (fputs_fndecl); - - tree fd = a68_low_func_param (fputs_fndecl, "fd", a68_int_type); - tree str = a68_low_func_param (fputs_fndecl, "str", CTYPE (M_STRING)); - DECL_ARGUMENTS (fputs_fndecl) = chainon (fd, str); - - a68_push_function_range (fputs_fndecl, a68_int_type, - true /* top_level */); - - - tree body = a68_build_libcall (A68_LIBCALL_POSIX_FPUTS, - a68_int_type, 4, - fd, - a68_multiple_elements (str), - a68_multiple_num_elems (str), - a68_multiple_stride (str, size_zero_node)); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fputs_fndecl)), - fputs_fndecl); -} - -tree -a68_posix_fgets (void) -{ - static tree fgets_fndecl; - - if (fgets_fndecl == NULL_TREE) - { - fgets_fndecl - = a68_low_toplevel_func_decl ("fgets", - build_function_type_list (CTYPE (M_REF_STRING), - a68_int_type, - a68_int_type, - NULL_TREE)); - announce_function (fgets_fndecl); - - tree fd = a68_low_func_param (fgets_fndecl, "fd", a68_int_type); - tree n = a68_low_func_param (fgets_fndecl, "n", a68_int_type); - DECL_ARGUMENTS (fgets_fndecl) = chainon (fd, n); - - a68_push_function_range (fgets_fndecl, CTYPE (M_REF_STRING), - true /* top_level */); - - tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); - TREE_ADDRESSABLE (len) = 1; - - tree call = a68_build_libcall (A68_LIBCALL_POSIX_FGETS, - CTYPE (M_REF_STRING), 3, - fd, n, - fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); - tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); - - tree lower_bound = ssize_int (1); - tree upper_bound = fold_convert (ssizetype, len); - tree elems_size = fold_build2 (MULT_EXPR, sizetype, - len, size_in_bytes (a68_char_type)); - tree body = a68_row_malloc (M_STRING, 1 /* dim */, - elems, elems_size, - &lower_bound, &upper_bound); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fgets_fndecl)), - fgets_fndecl); -} - -tree -a68_posix_gets (void) -{ - static tree gets_fndecl; - - if (gets_fndecl == NULL_TREE) - { - gets_fndecl - = a68_low_toplevel_func_decl ("gets", - build_function_type_list (CTYPE (M_REF_STRING), - a68_int_type, - NULL_TREE)); - announce_function (gets_fndecl); - - tree n = a68_low_func_param (gets_fndecl, "n", a68_int_type); - DECL_ARGUMENTS (gets_fndecl) = n; - - a68_push_function_range (gets_fndecl, CTYPE (M_REF_STRING), - true /* top_level */); - - tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); - TREE_ADDRESSABLE (len) = 1; - - tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETS, - CTYPE (M_REF_STRING), 2, - n, fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); - tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); - - tree lower_bound = ssize_int (1); - tree upper_bound = fold_convert (ssizetype, len); - tree elems_size = fold_build2 (MULT_EXPR, sizetype, - len, size_in_bytes (a68_char_type)); - tree body = a68_row_malloc (M_STRING, 1 /* dim */, - elems, elems_size, - &lower_bound, &upper_bound); - a68_pop_function_range (body); - } - - return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (gets_fndecl)), - gets_fndecl); -} diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc index 44abd5fe74d..533b9261afe 100644 --- a/gcc/algol68/a68-low-prelude.cc +++ b/gcc/algol68/a68-low-prelude.cc @@ -1923,296 +1923,3 @@ a68_lower_longlongrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UN { return a68_get_libcall (A68_LIBCALL_LONGLONGRANDOM); } - -/********* POSIX prelude. ***************/ - -tree -a68_lower_posixargc (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_argc (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixargv (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_argv (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixgetenv (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_getenv (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixputchar (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_putchar (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixputs (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_puts (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfconnect (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fconnect (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfopen (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fopen (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfcreate (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fcreate (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfclose (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fclose (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfsize (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fsize (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixlseek (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_lseek (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixseekcur (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 0); -} - -tree -a68_lower_posixseekend (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 1); -} - -tree -a68_lower_posixseekset (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 2); -} - -tree -a68_lower_posixstdinfiledes (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 0); -} - -tree -a68_lower_posixstdoutfiledes (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 1); -} - -tree -a68_lower_posixstderrfiledes (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - return build_int_cst (a68_int_type, 2); -} - -tree -a68_lower_posixfileodefault (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - /* Please keep in sync with libga68/ga68-posix.c */ - return build_int_cst (a68_bits_type, 0x99999999); -} - -tree -a68_lower_posixfileordwr (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - /* Please keep in sync with libga68/ga68-posix.c */ - return build_int_cst (a68_bits_type, 0x2); -} - -tree -a68_lower_posixfileordonly (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - /* Please keep in sync with libga68/ga68-posix.c */ - return build_int_cst (a68_bits_type, 0x0); -} - -tree -a68_lower_posixfileowronly (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - /* Please keep in sync with libga68/ga68-posix.c */ - return build_int_cst (a68_bits_type, 0x1); -} - -tree -a68_lower_posixfileotrunc (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - /* Please keep in sync with libga68/ga68-posix.c */ - return build_int_cst (a68_bits_type, 0x8); -} - -tree -a68_lower_posixerrno (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_errno (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixexit (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_exit (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixperror (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_perror (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixstrerror (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_strerror (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfputc (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fputc (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfputs (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fputs (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixgetchar (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_getchar (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - - -tree -a68_lower_posixfgetc (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fgetc (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixgets (NODE_T *p ATTRIBUTE_UNUSED, - LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_gets (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} - -tree -a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) -{ - tree t = a68_posix_fgets (); - if (CAN_HAVE_LOCATION_P (t)) - SET_EXPR_LOCATION (t, a68_get_node_location (p)); - return t; -} diff --git a/gcc/algol68/a68-low-runtime.def b/gcc/algol68/a68-low-runtime.def index 326e4d00bc9..5f12906a0ce 100644 --- a/gcc/algol68/a68-low-runtime.def +++ b/gcc/algol68/a68-low-runtime.def @@ -61,27 +61,6 @@ DEF_A68_RUNTIME (ARRAYDIM, "_libga68_dim", RT(VOID), DEF_A68_RUNTIME (RANDOM, "_libga68_random", RT(FLOAT), P0(), 0) DEF_A68_RUNTIME (LONGRANDOM, "_libga68_longrandom", RT(DOUBLE), P0(), 0) DEF_A68_RUNTIME (LONGLONGRANDOM, "_libga68_longlongrandom", RT(LONGDOUBLE), P0(), 0) -DEF_A68_RUNTIME (POSIX_FCONNECT, "_libga68_posixfconnect", RT(INT), P4(UNISTRPTR,SIZE,SIZE,INT), 0) -DEF_A68_RUNTIME (POSIX_FOPEN, "_libga68_posixfopen", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0) -DEF_A68_RUNTIME (POSIX_FCREATE, "_libga68_posixcreat", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0) -DEF_A68_RUNTIME (POSIX_FCLOSE, "_libga68_posixclose", RT(INT), P0(), 0) -DEF_A68_RUNTIME (POSIX_FSIZE, "_libga68_posixfsize", RT(LONGLONGINT), P1(INT), 0) -DEF_A68_RUNTIME (POSIX_ARGC, "_libga68_posixargc", RT(INT), P0(), 0) -DEF_A68_RUNTIME (POSIX_ARGV, "_libga68_posixargv", RT(UNISTRPTR), P2(INT, SIZEPTR), 0) -DEF_A68_RUNTIME (POSIX_PUTCHAR, "_libga68_posixputchar", RT(CHAR), P1(CHAR), 0) -DEF_A68_RUNTIME (POSIX_FPUTC, "_libga68_posixfputc", RT(CHAR), P2(INT,CHAR), 0) -DEF_A68_RUNTIME (POSIX_PUTS, "_libga68_posixputs", RT(VOID), P3(UNISTR,SIZE,SIZE), 0) -DEF_A68_RUNTIME (POSIX_FPUTS, "_libga68_posixfputs", RT(INT), P4(INT,UNISTRPTR,SIZE,SIZE), 0) -DEF_A68_RUNTIME (POSIX_GETCHAR, "_libga68_posixgetchar", RT(CHAR), P0(), 0) -DEF_A68_RUNTIME (POSIX_FGETC, "_libga68_posixfgetc", RT(CHAR), P1(INT), 0) -DEF_A68_RUNTIME (POSIX_GETS, "_libga68_posixgets", RT(UNISTRPTR), P2(INT,SIZEPTR), 0) -DEF_A68_RUNTIME (POSIX_FGETS, "_libga68_posixfgets", RT(UNISTRPTR), P3(INT,INT,SIZEPTR), 0) -DEF_A68_RUNTIME (POSIX_GETENV, "_libga68_posixgetenv", RT(VOID), P5(UNISTR,SIZE,SIZE,UNISTRPTR,SIZEPTR), 0) -DEF_A68_RUNTIME (POSIX_ERRNO, "_libga68_posixerrno", RT(INT), P0(), 0) -DEF_A68_RUNTIME (POSIX_EXIT, "_libga68_posixexit", RT(VOID), P1(INT), 0) -DEF_A68_RUNTIME (POSIX_PERROR, "_libga68_posixperror", RT(VOID), P3(UNISTR,SIZE,SIZE), 0) -DEF_A68_RUNTIME (POSIX_STRERROR, "_libga68_posixstrerror", RT(UNISTRPTR), P2(INT, SIZEPTR), 0) -DEF_A68_RUNTIME (POSIX_LSEEK, "_libga68_posixlseek", RT(LONGLONGINT), P3(INT,LONGLONGINT,INT), 0) DEF_A68_RUNTIME (U32_CMP2, "_libga68_u32_cmp2", RT(INT), P6(UNISTR, SIZE, SIZE, UNISTR, SIZE, SIZE), 0) #undef P0 diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc index 7df38c801e6..e4c4355ea88 100644 --- a/gcc/algol68/a68-low.cc +++ b/gcc/algol68/a68-low.cc @@ -39,6 +39,7 @@ #include "gimplify.h" #include "dumpfile.h" #include "convert.h" +#include "options.h" #include "a68.h" @@ -631,17 +632,17 @@ a68_make_variable_declaration_decl (NODE_T *identifier, return decl; } -/* Make an extern declaration for a formal hole. */ +/* Make an extern declaration for a formal hole. + + Note that this function is not used for formal holes with proc modes, called + from a68_wrap_formal_var_hole. See a68_wrap_formal_proc_hole. */ tree a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol) { - /* The CTYPE of MODE is a pointer to a function. We need the pointed - function type for the FUNCTION_DECL. */ - tree type = (IS (MOID (p), PROC_SYMBOL) - ? TREE_TYPE (CTYPE (MOID (p))) - : CTYPE (MOID (p))); + gcc_assert (!IS (MOID (p), PROC_SYMBOL)); + tree type = CTYPE (MOID (p)); const char *sym = (strlen (extern_symbol) > 0 && extern_symbol[0] == '&' ? extern_symbol + 1 : extern_symbol); @@ -1246,6 +1247,23 @@ lower_revelations (NODE_T *p, LOW_CTX_T ctx, bool prelude) return NULL_TREE; } +/* Lower the declaration of a prelude or postlude. */ + +static tree +lower_lude_decl (const char *module, bool postludep) +{ + char *symbol = xasprintf ("%s__%s", + module, + postludep ? "postlude" : "prelude"); + tree fdecl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL, + get_identifier (symbol), + build_function_type (void_type_node, void_list_node)); + free (symbol); + DECL_EXTERNAL (fdecl) = 1; + TREE_PUBLIC (fdecl) = 1; + return fdecl; +} + /* Lower a module text. module text : revelation part, def part, postlude part, fed symbol ; @@ -1318,6 +1336,15 @@ lower_module_text (NODE_T *p, LOW_CTX_T ctx) { a68_push_stmt_list (NULL); { + if (!flag_building_libga68) + { + /* Add calls to implicitly accessed standard preludes. */ + tree standard_prelude = lower_lude_decl ("STANDARD", false); + tree posix_prelude = lower_lude_decl ("POSIX", false); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_prelude, 0)); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_prelude, 0)); + } + /* Add calls to preludes of modules in REVELATION_PART. */ lower_revelations (revelation_part, ctx, true /* prelude */); a68_add_stmt (a68_lower_tree (prelude_enquiry, ctx)); @@ -1367,14 +1394,24 @@ lower_module_text (NODE_T *p, LOW_CTX_T ctx) { a68_push_stmt_list (NULL); { - /* Add calls to postludes of modules in REVELATION_PART. */ - lower_revelations (revelation_part, ctx, false /* prelude */); /* Perhaps the postlude code, if there is one. */ NODE_T *postlude_serial = NO_NODE; if (postlude_part != NO_NODE) postlude_serial = NEXT_SUB (postlude_part); if (postlude_serial != NO_NODE) a68_add_stmt (a68_lower_tree (postlude_serial, ctx)); + + /* Add calls to postludes of modules in REVELATION_PART. */ + lower_revelations (revelation_part, ctx, false /* prelude */); + + if (!flag_building_libga68) + { + /* Add calls to implicitly accessed standard postludes. */ + tree standard_postlude = lower_lude_decl ("STANDARD", true); + tree posix_postlude = lower_lude_decl ("POSIX", true); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_postlude, 0)); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_postlude, 0)); + } } tree do_postlude = a68_pop_stmt_list (); @@ -1473,10 +1510,24 @@ lower_particular_program (NODE_T *p, LOW_CTX_T ctx) void_type_node /* result_type */); /* Lower the body of the function. */ + + tree standard_prelude = lower_lude_decl ("STANDARD", false); + tree standard_postlude = lower_lude_decl ("STANDARD", true); + tree posix_prelude = lower_lude_decl ("POSIX", false); + tree posix_postlude = lower_lude_decl ("POSIX", true); + NODE_T *enclosed_clause = (IS (SUB (p), ENCLOSED_CLAUSE) ? SUB (p) : NEXT (SUB (p))); - tree body_expr = a68_lower_tree (enclosed_clause, ctx); - a68_pop_function_range (body_expr); + + a68_push_range (M_VOID); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_prelude, 0)); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_prelude, 0)); + a68_add_stmt (a68_lower_tree (enclosed_clause, ctx)); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_postlude, 0)); + a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_postlude, 0)); + + tree body = a68_pop_range (); + a68_pop_function_range (body); return NULL_TREE; } diff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc index 585a4aa691d..8a96f2ce83d 100644 --- a/gcc/algol68/a68-moids-misc.cc +++ b/gcc/algol68/a68-moids-misc.cc @@ -1207,7 +1207,11 @@ a68_is_c_mode (MOID_T *m, int level) return a68_is_c_mode (SUB (m), level + 1); else if (IS (m, PROC_SYMBOL)) { - bool yielded_mode_valid = a68_is_c_mode (SUB (m)); + bool yielded_mode_valid = + ((level == 0 + && (SUB (m) == M_STRING + || (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING))) + || a68_is_c_mode (SUB (m), level + 1)); bool params_valid = true; for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z)) diff --git a/gcc/algol68/a68-parser-extract.cc b/gcc/algol68/a68-parser-extract.cc index 611ef12d2eb..312e624c4f5 100644 --- a/gcc/algol68/a68-parser-extract.cc +++ b/gcc/algol68/a68-parser-extract.cc @@ -197,16 +197,27 @@ skip_pack_declarer (NODE_T *p) return p; } -/* Extract the revelation associated with the module MODULE. The node Q is - used for symbol table and diagnostic purposes. Publicized modules are - recursively extracted as well. This call may result in one or more - errors. */ +/* Extract the revelation associated with the module MODULE. -static void -extract_revelation (NODE_T *q, const char *module, TAG_T *tag) + The node Q is used for symbol table and diagnostic purposes + + Publicized modules are recursively extracted as well. This call may result + in one or more errors. + + If FILENAME is not NULL then the module exports are looked in + libFILENAME.so, FILENAME.o, etc. If it is NULL, the filename is derived + from the module name. + + This function is visible externally because it is used to extract + revelations of modules distributed as part of libga68, in + a68-parser-prelude.cc */ + +void +a68_extract_revelation (NODE_T *q, const char *module, const char *filename, + TAG_T *tag) { /* Import the MOIF and install it in the tag. */ - MOIF_T *moif = a68_open_packet (module); + MOIF_T *moif = a68_open_packet (module, filename); if (moif == NULL) { a68_error (q, "cannot find module Z", module); @@ -246,7 +257,7 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag) extract_revelation calls is properly done. */ for (EXTRACT_T *e : MODULES (moif)) - extract_revelation (q, EXTRACT_SYMBOL (e), NO_TAG); + a68_extract_revelation (q, EXTRACT_SYMBOL (e), filename, NO_TAG); /* Store mode indicants from the MOIF in the symbol table, and also in the moid list. */ @@ -267,6 +278,7 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag) /* INDICANT node. */ NODE_T *n = a68_some_node (a68_demangle_symbol (NAME (moif), EXTRACT_SYMBOL (e))); + MOID (n) = EXTRACT_MODE (e); /* EQUALS_SYMBOL node. */ NEXT (n) = a68_some_node ("="); ATTRIBUTE (NEXT (n)) = EQUALS_SYMBOL; @@ -351,6 +363,21 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag) } } +/* This version of a68_extract_revelation gets a symbol table and line info + rather than a node. It is used to extract revelations from standard modules + distributed in the run-time library. See a68-parser-prelude.cc */ + +void +a68_extract_revelation (TABLE_T *t, LINE_T *l, + const char *module, const char *filename, + TAG_T *tag) +{ + NODE_T *q = a68_some_node (""); + TABLE (q) = t; + LINE (INFO (q)) = l; + a68_extract_revelation (q, module, filename, tag); +} + /* Search [MODE|MODULE] A = .., B = .. and ACCESS A, B, .. and store indicants. */ @@ -389,7 +416,8 @@ a68_extract_indicants (NODE_T *p) { TAG_T *tag = a68_add_tag (TABLE (bold_tag), MODULE_SYMBOL, bold_tag, NO_MOID, STOP); gcc_assert (tag != NO_TAG); - extract_revelation (bold_tag, NSYMBOL (bold_tag), tag); + a68_extract_revelation (bold_tag, NSYMBOL (bold_tag), + NULL /* filename */, tag); } } } diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc index 2916b2199ba..e283c2c3f11 100644 --- a/gcc/algol68/a68-parser-prelude.cc +++ b/gcc/algol68/a68-parser-prelude.cc @@ -22,6 +22,7 @@ #include "config.h" #include "system.h" #include "coretypes.h" +#include "options.h" #include "a68.h" @@ -1305,6 +1306,22 @@ stand_prelude (void) m = a68_proc (M_VOID, M_SEMA, NO_MOID); a68_op (A68_STD, "UP", m); a68_op (A68_STD, "DOWN", m); + + + /* Load Algol 68 parts. */ + if (!flag_building_libga68) + a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))), + "STANDARD", "ga68"); +} + +/* Transput. */ + +static void +stand_transput (void) +{ + // if (!flag_building_libga68) + // a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))), + // "TRANSPUT", "ga68"); } /* GNU extensions for the standenv. */ @@ -1404,83 +1421,11 @@ gnu_prelude (void) static void posix_prelude (void) { - MOID_T *m = NO_MOID; - - /* Environment variables. */ - m = a68_proc (M_STRING, M_STRING, NO_MOID); - a68_idf (A68_EXT, "getenv", m, a68_lower_posixgetenv); - /* Exit status handling. */ - m = a68_proc (M_VOID, M_INT, NO_MOID); - a68_idf (A68_EXT, "posixexit", m, a68_lower_posixexit); - /* Argument handling. */ - m = A68_MCACHE (proc_int); - a68_idf (A68_EXT, "argc", m, a68_lower_posixargc); - m = a68_proc (M_STRING, M_INT, NO_MOID); - a68_idf (A68_EXT, "argv", m, a68_lower_posixargv); - /* Error procedures. */ - m = A68_MCACHE (proc_int); - a68_idf (A68_EXT, "errno", m, a68_lower_posixerrno); - m = a68_proc (M_VOID, M_STRING, NO_MOID); - a68_idf (A68_EXT, "perror", m, a68_lower_posixperror); - m = a68_proc (M_STRING, M_INT, NO_MOID); - a68_idf (A68_EXT, "strerror", m, a68_lower_posixstrerror); - /* I/O identifiers. */ - a68_idf (A68_EXT, "stdin", M_INT, a68_lower_posixstdinfiledes); - a68_idf (A68_EXT, "stdout", M_INT, a68_lower_posixstdoutfiledes); - a68_idf (A68_EXT, "stderr", M_INT, a68_lower_posixstderrfiledes); - a68_idf (A68_EXT, "fileodefault", M_BITS, a68_lower_posixfileodefault); - a68_idf (A68_EXT, "fileordwr", M_BITS, a68_lower_posixfileordwr); - a68_idf (A68_EXT, "fileordonly", M_BITS, a68_lower_posixfileordonly); - a68_idf (A68_EXT, "fileowronly", M_BITS, a68_lower_posixfileowronly); - a68_idf (A68_EXT, "fileotrunc", M_BITS, a68_lower_posixfileotrunc); - /* Opening and closing files. */ - m = a68_proc (M_INT, M_STRING, M_BITS, NO_MOID); - a68_idf (A68_EXT, "fopen", m, a68_lower_posixfopen); - a68_idf (A68_EXT, "fcreate", m, a68_lower_posixfcreate); - m = A68_MCACHE (proc_int_int); - a68_idf (A68_EXT, "fclose", m, a68_lower_posixfclose); - /* Getting properties of files. */ - m = a68_proc (M_LONG_LONG_INT, M_INT, NO_MOID); - a68_idf (A68_EXT, "fsize", m, a68_lower_posixfsize); - m = a68_proc (M_LONG_LONG_INT, M_INT, M_LONG_LONG_INT, M_INT, NO_MOID); - a68_idf (A68_EXT, "lseek", m, a68_lower_posixlseek); - a68_idf (A68_EXT, "seekcur", M_INT, a68_lower_posixseekcur); - a68_idf (A68_EXT, "seekend", M_INT, a68_lower_posixseekend); - a68_idf (A68_EXT, "seekset", M_INT, a68_lower_posixseekset); - /* Sockets. */ - m = a68_proc (M_INT, M_STRING, M_INT, NO_MOID); - a68_idf (A68_EXT, "fconnect", m, a68_lower_posixfconnect); - /* String and character output. */ - m = a68_proc (M_CHAR, M_CHAR, NO_MOID); - a68_idf (A68_EXT, "putchar", m, a68_lower_posixputchar); - m = a68_proc (M_VOID, M_STRING, NO_MOID); - a68_idf (A68_EXT, "puts", m, a68_lower_posixputs); - m = a68_proc (M_CHAR, M_INT, M_CHAR, NO_MOID); - a68_idf (A68_EXT, "fputc", m, a68_lower_posixfputc); - m = a68_proc (M_INT, M_INT, M_STRING, NO_MOID); - a68_idf (A68_EXT, "fputs", m, a68_lower_posixfputs); - /* String and character input. */ - m = A68_MCACHE (proc_char); - a68_idf (A68_EXT, "getchar", m, a68_lower_posixgetchar); - m = a68_proc (M_CHAR, M_INT, NO_MOID); - a68_idf (A68_EXT, "fgetc", m, a68_lower_posixfgetc); - m = a68_proc (M_REF_STRING, M_INT, NO_MOID); - a68_idf (A68_EXT, "gets", m, a68_lower_posixgets); - m = a68_proc (M_REF_STRING, M_INT, M_INT, NO_MOID); - a68_idf (A68_EXT, "fgets", m, a68_lower_posixfgets); -} - -/* Transput. */ - -static void -stand_transput (void) -{ - /* Most of the standard transput is implemented in Algol 68 and doesn't - require compiler support. See libga68/transput.a68.in */ + if (!flag_building_libga68) + a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))), + "POSIX", "ga68"); } -/* Build the standard environ symbol table. */ - void a68_make_standard_environ (void) { diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h index cf195f213e1..d3cf81d05c7 100644 --- a/gcc/algol68/a68.h +++ b/gcc/algol68/a68.h @@ -338,6 +338,10 @@ void a68_extract_operators (NODE_T *p); void a68_extract_labels (NODE_T *p, int expect); void a68_extract_declarations (NODE_T *p); void a68_elaborate_bold_tags (NODE_T *p); +void a68_extract_revelation (NODE_T *q, const char *module, + const char *filename, TAG_T *tag = NO_TAG); +void a68_extract_revelation (TABLE_T *t, LINE_T *l, const char *module, + const char *filename, TAG_T *tag = NO_TAG); /* a68-parser-keywords.cc */ @@ -584,30 +588,6 @@ tree a68_complex_im (tree z); tree a68_complex_conj (MOID_T *mode, tree z); tree a68_complex_widen_from_real (MOID_T *mode, tree r); -/* a68-low-posix.cc */ - -tree a68_posix_argc (void); -tree a68_posix_argv (void); -tree a68_posix_getenv (void); -tree a68_posix_putchar (void); -tree a68_posix_puts (void); -tree a68_posix_fconnect (void); -tree a68_posix_fcreate (void); -tree a68_posix_fopen (void); -tree a68_posix_fclose (void); -tree a68_posix_fsize (void); -tree a68_posix_lseek (void); -tree a68_posix_errno (void); -tree a68_posix_exit (void); -tree a68_posix_perror (void); -tree a68_posix_strerror (void); -tree a68_posix_getchar (void); -tree a68_posix_fgetc (void); -tree a68_posix_fputc (void); -tree a68_posix_fputs (void); -tree a68_posix_gets (void); -tree a68_posix_fgets (void); - /* a68-low-reals.cc */ tree a68_get_real_skip_tree (MOID_T *m); @@ -1085,38 +1065,6 @@ tree a68_lower_longlongrandom (NODE_T *p, LOW_CTX_T ctx); tree a68_lower_set3 (NODE_T *p, LOW_CTX_T ctx); tree a68_lower_clear3 (NODE_T *p, LOW_CTX_T ctx); tree a68_lower_test3 (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixargc (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixargv (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixputchar (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixputs (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfputc (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfputs (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixgetenv (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfconnect (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfopen (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfcreate (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfclose (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfsize (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixlseek (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixseekcur (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixseekend (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixseekset (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixstdinfiledes (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixstdoutfiledes (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixstderrfiledes (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfileodefault (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfileordwr (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfileordonly (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfileowronly (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfileotrunc (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixerrno (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixexit (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixperror (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixstrerror (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixgetchar (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfgetc (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixgets (NODE_T *p, LOW_CTX_T ctx); -tree a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx); /* a68-exports.cc */ @@ -1126,7 +1074,7 @@ void a68_do_exports (NODE_T *p); /* a68-imports.cc */ -MOIF_T *a68_open_packet (const char *module); +MOIF_T *a68_open_packet (const char *module, const char *filename = NULL); bool a68_process_module_map (const char *map, const char **errmsg); char *a68_find_object_export_data (const std::string &filename, int fd, off_t offset, size_t *size); diff --git a/gcc/algol68/lang.opt b/gcc/algol68/lang.opt index 2f9973b552f..6480f4bdf89 100644 --- a/gcc/algol68/lang.opt +++ b/gcc/algol68/lang.opt @@ -80,6 +80,9 @@ fcheck= Algol68 RejectNegative JoinedOrMissing -fcheck=[...] Specify which runtime checks are to be performed. +fbuilding-libga68 +Algol68 Undocumented Var(flag_building_libga68) + fa68-dump-modes Algol68 Var(flag_a68_dump_modes) Dump Algol 68 modes after parsing. diff --git a/gcc/testsuite/algol68/compile/error-nest-4.a68 b/gcc/testsuite/algol68/compile/error-nest-4.a68 index 312b96878a5..f67cbe20a02 100644 --- a/gcc/testsuite/algol68/compile/error-nest-4.a68 +++ b/gcc/testsuite/algol68/compile/error-nest-4.a68 @@ -1,4 +1,4 @@ -begin string s = +begin []string s = nest C "lala"; { dg-error "" } union(int,real) x = nest C "x"; { dg-error "" } diff --git a/gcc/testsuite/algol68/compile/warning-hidding-5.a68 b/gcc/testsuite/algol68/compile/warning-hidding-5.a68 index f9bc4a41ea4..483ce859e4d 100644 --- a/gcc/testsuite/algol68/compile/warning-hidding-5.a68 +++ b/gcc/testsuite/algol68/compile/warning-hidding-5.a68 @@ -1,6 +1,6 @@ { dg-options "-Whidden-declarations=none" } begin real b; - begin int getchar = 10; + begin int maxint = 10; int b; op UPB = (int i, union (int,string) v) int: (v | (string s): UPB s | 0); diff --git a/gcc/testsuite/algol68/compile/warning-hidding-6.a68 b/gcc/testsuite/algol68/compile/warning-hidding-6.a68 index a865103bcdf..be419b30c56 100644 --- a/gcc/testsuite/algol68/compile/warning-hidding-6.a68 +++ b/gcc/testsuite/algol68/compile/warning-hidding-6.a68 @@ -1,6 +1,6 @@ { dg-options "-Whidden-declarations=prelude" } begin real b; - begin int getchar = 10; { dg-warning "hides" } + begin int maxint = 10; { dg-warning "hides" } int b; op UPB = (int i, union (int,string) v) int: { dg-warning "hides" } (v | (string s): UPB s | 0); diff --git a/gcc/testsuite/lib/algol68.exp b/gcc/testsuite/lib/algol68.exp index acdfc4b6ba3..9953fe27794 100644 --- a/gcc/testsuite/lib/algol68.exp +++ b/gcc/testsuite/lib/algol68.exp @@ -134,7 +134,7 @@ proc algol68_init { args } { set specpath [get_multilibs] } set algol68_init_set_ALGOL68_UNDER_TEST 1 - set ALGOL68_UNDER_TEST [findfile $base_dir/../../ga68 "$base_dir/../../ga68 -B$base_dir/../../ -B$specpath/libga68/" [findfile $base_dir/ga68 "$base_dir/ga68 -B$base_dir/" [transform ga68]]] + set ALGOL68_UNDER_TEST [findfile $base_dir/../../ga68 "$base_dir/../../ga68 -B$base_dir/../.. -B$specpath/libga68 -I$base_dir/../../.libs -I$specpath/libga68/.libs" [findfile $base_dir/ga68 "$base_dir/ga68 -B$base_dir" [transform ga68]]] } } } diff --git a/libga68/Makefile.am b/libga68/Makefile.am index e9341485fde..4430e1ef0f1 100644 --- a/libga68/Makefile.am +++ b/libga68/Makefile.am @@ -134,8 +134,8 @@ libga68_la_LIBTOOLFLAGS = libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES) libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \ $(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68) -libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo -libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo +libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo +libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo # Rules to build the Algol 68 code in the library. @@ -143,15 +143,18 @@ LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ --mode=compile $(A68) $(AM_A68FLAGS) .a68.o: - $(A68) -o $@ $(A68FLAGS) -c $< + $(A68) -o $@ $(A68FLAGS) -fbuilding-libga68 -c $< .a68.lo: - $(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -c -o $@ $< + $(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $< transput.a68 : transput.a68.in $(AWK) -f $(srcdir)/sppp.awk $< > $@ -BUILT_SOURCES = transput.a68 +standard.a68 : standard.a68.in + $(AWK) -f $(srcdir)/sppp.awk $< > $@ + +BUILT_SOURCES = transput.a68 standard.a68 # target overrides -include $(tmake_file) diff --git a/libga68/Makefile.in b/libga68/Makefile.in index e2ce1a2c7b7..d5ed7df7f48 100644 --- a/libga68/Makefile.in +++ b/libga68/Makefile.in @@ -475,14 +475,14 @@ libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES) libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \ $(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68) -libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo -libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo +libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo +libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo # Rules to build the Algol 68 code in the library. LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ --mode=compile $(A68) $(AM_A68FLAGS) -BUILT_SOURCES = transput.a68 +BUILT_SOURCES = transput.a68 standard.a68 MULTISRCTOP = MULTIBUILDTOP = MULTIDIRS = @@ -896,14 +896,17 @@ uninstall-am: uninstall-toolexeclibDATA \ @LIBGA68_USE_SYMVER_SUN_TRUE@@LIBGA68_USE_SYMVER_TRUE@ > $@ || (rm -f $@ ; exit 1) .a68.o: - $(A68) -o $@ $(A68FLAGS) -c $< + $(A68) -o $@ $(A68FLAGS) -fbuilding-libga68 -c $< .a68.lo: - $(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -c -o $@ $< + $(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $< transput.a68 : transput.a68.in $(AWK) -f $(srcdir)/sppp.awk $< > $@ +standard.a68 : standard.a68.in + $(AWK) -f $(srcdir)/sppp.awk $< > $@ + # target overrides -include $(tmake_file) diff --git a/libga68/ga68-posix.c b/libga68/ga68-posix.c index 221fb1a19fe..06ca1d921b0 100644 --- a/libga68/ga68-posix.c +++ b/libga68/ga68-posix.c @@ -47,6 +47,10 @@ static int _libga68_errno; /* Simple I/O based on POSIX file descriptors. */ +int _libga68_stdin = 0; +int _libga68_stdout = 1; +int _libga68_stderr = 2; + int _libga68_posixerrno (void) { @@ -67,11 +71,11 @@ _libga68_posixperror (uint32_t *s, size_t len, size_t stride) _libga68_free_internal (u8str); } -uint32_t * -_libga68_posixstrerror (int errnum, size_t *len) +void +_libga68_posixstrerror (int errnum, uint32_t **r, size_t *rlen) { const char *str = strerror (errnum); - return _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, len); + *r = _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, rlen); } /* Helper for _libga68_posixfopen. */ @@ -83,11 +87,11 @@ _libga68_open (const char *path, unsigned int flags) return fd; } -#define FILE_O_DEFAULT 0x99999999 -#define FILE_O_RDONLY 0x0 -#define FILE_O_WRONLY 0x1 -#define FILE_O_RDWR 0x2 -#define FILE_O_TRUNC 0x8 +unsigned int _libga68_file_o_default = 0x99999999; +unsigned int _libga68_file_o_rdonly = 0x0; +unsigned int _libga68_file_o_wronly = 0x1; +unsigned int _libga68_file_o_rdwr = 0x2; +unsigned int _libga68_file_o_trunc = 0x8; int _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride, @@ -101,7 +105,7 @@ _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride, /* Default mode: try read-write initially. If that fails, then try read-only. If that fails, then try write-only. */ - if (flags == FILE_O_DEFAULT) + if (flags == _libga68_file_o_default) { openflags = O_RDWR; if ((fd = _libga68_open (filepath, openflags)) < 0) @@ -119,13 +123,13 @@ _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride, return fd; } - if (flags & FILE_O_RDONLY) + if (flags & _libga68_file_o_rdonly) openflags |= O_RDONLY; - if (flags & FILE_O_WRONLY) + if (flags & _libga68_file_o_wronly) openflags |= O_WRONLY; - if (flags & FILE_O_RDWR) + if (flags & _libga68_file_o_rdwr) openflags |= O_RDWR; - if (flags & FILE_O_TRUNC) + if (flags & _libga68_file_o_trunc) openflags |= O_TRUNC; fd = _libga68_open (filepath, openflags); @@ -164,19 +168,19 @@ _libga68_posixargc (void) /* Implementation of the posix prelude `posix argv'. */ -uint32_t * -_libga68_posixargv (int n, size_t *len) +void +_libga68_posixargv (int n, uint32_t **r, size_t *rlen) { if (n < 0 || n > _libga68_argc) { /* Return an empty string. */ - *len = 0; - return NULL; + *rlen = 0; + *r = NULL; } else { char *arg = _libga68_argv[n - 1]; - return _libga68_u8_to_u32 (arg, strlen (arg), NULL, len); + *r = _libga68_u8_to_u32 (arg, strlen (arg), NULL, rlen); } } @@ -307,8 +311,8 @@ _libga68_posixgetchar (void) /* Implementation of the posix prelude `posix fgets'. */ -uint32_t * -_libga68_posixfgets (int fd, int nchars, size_t *len) +void +_libga68_posixfgets (int fd, int nchars, uint32_t **r, size_t *rlen) { uint32_t *res = NULL; int n = 0; @@ -347,16 +351,16 @@ _libga68_posixfgets (int fd, int nchars, size_t *len) res = _libga68_realloc (res, n * 80 * sizeof (uint32_t)); } - *len = n; - return res; + *rlen = n; + *r = res; } /* Implementation of the posix prelude `posix gets'. */ -uint32_t * -_libga68_posixgets (int nchars, size_t *len) +void +_libga68_posixgets (int nchars, uint32_t **r, size_t *rlen) { - return _libga68_posixfgets (0, nchars, len); + _libga68_posixfgets (0, nchars, r, rlen); } /* Implementation of the posix prelude `fconnect'. */ @@ -429,10 +433,15 @@ _libga68_posixfsize (int fd) } /* Implementation of the posix prelude `lseek'. */ + #define A68_SEEK_CUR 0 #define A68_SEEK_END 1 #define A68_SEEK_SET 2 +const int _libga68_seek_cur = A68_SEEK_CUR; +const int _libga68_seek_end = A68_SEEK_END; +const int _libga68_seek_set = A68_SEEK_SET; + long long int _libga68_posixlseek (int fd, long long int offset, int whence) { diff --git a/libga68/ga68.h b/libga68/ga68.h index 316a9e318d5..9c104e60437 100644 --- a/libga68/ga68.h +++ b/libga68/ga68.h @@ -88,14 +88,14 @@ long double _libga68_longlongrandom (void); int _libga68_posixerrno (void); void _libga68_posixexit (int) __attribute__ ((__noreturn__)); void _libga68_posixperror (uint32_t *s, size_t len, size_t stride); -uint32_t *_libga68_posixstrerror (int errnum, size_t *len); +void _libga68_posixstrerror (int errnum, uint32_t **r, size_t *rlen); long long int _libga68_posixfsize (int fd); int _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride, unsigned int flags); int _libga68_posixcreat (uint32_t *pathname, size_t len, size_t stride, uint32_t mode); int _libga68_posixclose (int fd); int _libga68_posixargc (void); -uint32_t *_libga68_posixargv (int n, size_t *len); +void _libga68_posixargv (int n, uint32_t **r, size_t *rlen); void _libga68_posixgetenv (uint32_t *s, size_t len, size_t stride, uint32_t **r, size_t *rlen); void _libga68_posixputs (uint32_t *s, size_t len, size_t stride); @@ -105,8 +105,8 @@ int _libga68_posixfputs (int fd, uint32_t *s, size_t len, size_t stride); uint32_t _libga68_posixgetchar (void); uint32_t _libga68_posixfgetc (int fd); -uint32_t *_libga68_posixfgets (int fd, int nchars, size_t *len); -uint32_t *_libga68_posixgets (int nchars, size_t *len); +void _libga68_posixfgets (int fd, int nchars, uint32_t **r, size_t *rlen); +void _libga68_posixgets (int nchars, uint32_t **r, size_t *rlen); int _libga68_posixfconnect (uint32_t *str, size_t len, size_t stride, int port); diff --git a/libga68/posix.a68 b/libga68/posix.a68 new file mode 100644 index 00000000000..f8908213276 --- /dev/null +++ b/libga68/posix.a68 @@ -0,0 +1,65 @@ +{ posix.a68 - POSIX prelude. + + Copyright (C) 2026 Jose E. Marchesi + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License + and a copy of the GCC Runtime Library Exception along with this + program; see the files COPYING3 and COPYING.RUNTIME respectively. + If not, see <http://www.gnu.org/licenses/>. } + +module POSIX = +def + pub int stdin = nest C "_libga68_stdin", + stdout = nest C "_libga68_stdout", + stderr = nest C "_libga68_stderr"; + + pub bits file_o_default = nest C "_libga68_file_o_default", + file_o_rdwr = nest C "_libga68_file_o_rdwr", + file_o_rdonly = nest C "_libga68_file_o_rdonly", + file_o_wronly = nest C "_libga68_file_o_wronly", + file_o_trunc = nest C "_libga68_file_o_trunc"; + + pub int seekcur = nest C "_libga68_seek_cur", + seekend = nest C "_libga68_seek_end", + seekset = nest C "_libga68_seek_set"; + + pub proc int errno = nest C "_libga68_posixerrno", + argc = nest C "_libga68_posixargc"; + pub proc(int)string argv = nest C "_libga68_posixargv"; + pub proc(int)string strerror = nest C "_libga68_posixstrerror"; + pub proc(string,bits)int fopen = nest C "_libga68_posixfopen", + fcreate = nest C "_libga68_posixcreat"; + pub proc(string,int)int fconnect = nest C "_libga68_posixfconnect"; + pub proc(int)int fclose = nest C "_libga68_posixclose"; + pub proc(int)long long int + fsize = nest C "_libga68_posixfsize"; + pub proc(int,long long int,int)long long int + lseek = nest C "_libga68_posixlseek"; + pub proc char getchar = nest C "_libga68_posixgetchar"; + pub proc(char)char putchar = nest C "_libga68_posixputchar"; + pub proc(int)char fgetc = nest C "_libga68_posixfgetc"; + pub proc(int,char)char fputc = nest C "_libga68_posixfputc"; + pub proc(int)ref string gets = nest C "_libga68_posixgets"; + pub proc(string)void puts = nest C "_libga68_posixputs"; + pub proc(int,int)ref string fgets = nest C "_libga68_posixfgets"; + pub proc(int,string)int fputs = nest C "_libga68_posixfputs"; + pub proc(int)void posix_exit = nest C "_libga68_posixexit"; + pub proc(string)void perror = nest C "_libga68_posixperror"; + pub proc(string)string getenv = nest C "_libga68_posixgetenv"; + + skip +fed diff --git a/libga68/standard.a68.in b/libga68/standard.a68.in new file mode 100644 index 00000000000..630c7e5a239 --- /dev/null +++ b/libga68/standard.a68.in @@ -0,0 +1,29 @@ +{ Process this file with sppp.awk -*- mode: a68 -*- } + +{ standard.a68.in - Standard prelude, a68 part. + + Copyright (C) 2026 Jose E. Marchesi + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License + and a copy of the GCC Runtime Library Exception along with this + program; see the files COPYING3 and COPYING.RUNTIME respectively. + If not, see <http://www.gnu.org/licenses/>. } + +module Standard = +def + skip +fed diff --git a/libga68/transput.a68.in b/libga68/transput.a68.in index 37b804de655..4dbef44ddfc 100644 --- a/libga68/transput.a68.in +++ b/libga68/transput.a68.in @@ -1,4 +1,4 @@ -{ Process this file with sppp.awk } +{ Process this file with sppp.awk -*- mode: a68 -*- } { transput.a68.in - Standard transput. -- 2.39.5
