https://gcc.gnu.org/g:b67e045af7c2a91f13f48075a48ec63018c47a19
commit r16-5762-gb67e045af7c2a91f13f48075a48ec63018c47a19 Author: Jose E. Marchesi <[email protected]> Date: Sat Oct 11 19:54:57 2025 +0200 a68: libga68: sources, spec and misc files Signed-off-by: Jose E. Marchesi <[email protected]> ChangeLog * libga68/README: New file. * libga68/ga68-alloc.c: Likewise. * libga68/ga68-error.c: Likewise. * libga68/ga68-posix.c: Likewise. * libga68/ga68-standenv.c: Likewise. * libga68/ga68-unistr.c: Likewise. * libga68/ga68.h: Likewise. * libga68/libga68.c: Likewise. * libga68/libga68.spec.in: Likewise. Diff: --- libga68/README | 2 + libga68/ga68-alloc.c | 114 +++++++++ libga68/ga68-error.c | 151 ++++++++++++ libga68/ga68-posix.c | 463 ++++++++++++++++++++++++++++++++++++ libga68/ga68-standenv.c | 48 ++++ libga68/ga68-unistr.c | 615 ++++++++++++++++++++++++++++++++++++++++++++++++ libga68/ga68.h | 126 ++++++++++ libga68/libga68.c | 52 ++++ libga68/libga68.spec.in | 11 + 9 files changed, 1582 insertions(+) diff --git a/libga68/README b/libga68/README new file mode 100644 index 000000000000..23929a60451e --- /dev/null +++ b/libga68/README @@ -0,0 +1,2 @@ +This is the GNU Algol 68 run-time library. It provides the run-time +components needed by programs compiled by the ga68 compiler. diff --git a/libga68/ga68-alloc.c b/libga68/ga68-alloc.c new file mode 100644 index 000000000000..1cf922eb2115 --- /dev/null +++ b/libga68/ga68-alloc.c @@ -0,0 +1,114 @@ +/* Run-time routines for memory allocation. + + Copyright (C) 2025 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/>. */ + +#include <stdlib.h> + +#include "ga68.h" + +/* Heap allocation routines. */ + +void +_libga68_free_internal (void *pt) +{ + free (pt); +} + +void * +_libga68_malloc_internal (size_t size) +{ + void *res = (void *) malloc (size); + if (!res) + _libga68_abort ("Virtual memory exhausted\n"); + return res; +} + +#if LIBGA68_WITH_GC +#include <gc/gc.h> + +void +_libga68_init_heap (void) +{ + if (!GC_is_init_called ()) + { + GC_INIT (); + /* GC_allow_register_threads (); */ + } +} + +void * +_libga68_realloc (void *ptr, size_t size) +{ + void *res = (void *) GC_realloc (ptr, size); + if (!res) + _libga68_abort ("Virtual memory exhausted\n"); + return res; +} + +void * +_libga68_realloc_unchecked (void *ptr, size_t size) +{ + void *res = (void *) GC_realloc (ptr, size); + return res; +} + +void * +_libga68_malloc (size_t size) +{ + void *res = (void *) GC_malloc (size); + if (!res) + _libga68_abort ("Virtual memory exhausted\n"); + return res; +} + +#else + +void +_libga68_init_heap (void) +{ +} + +void * +_libga68_realloc (void *ptr, size_t size) +{ + void *res = (void *) realloc (ptr, size); + if (!res) + _libga68_abort ("Virtual memory exhausted\n"); + return res; +} + +void * +_libga68_realloc_unchecked (void *ptr, size_t size) +{ + void *res = (void *) realloc (ptr, size); + return res; +} + +void * +_libga68_malloc (size_t size) +{ + void *res = (void *) malloc (size); + if (!res) + _libga68_abort ("Virtual memory exhausted\n"); + return res; +} + +#endif /* !LIBGA68_WITH_GC */ diff --git a/libga68/ga68-error.c b/libga68/ga68-error.c new file mode 100644 index 000000000000..28f71659645f --- /dev/null +++ b/libga68/ga68-error.c @@ -0,0 +1,151 @@ +/* Support run-time routines for error handling. + + Copyright (C) 2025 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/>. */ + +#include <stdio.h> +#include <stdlib.h> /* For abort. */ + +#include "ga68.h" + +/* Run-time error handling. + + Please use the following format when outputing runtime error messages: + + FILE:LINE:[COLUMN:] TEXT + + This keeps the output aligned with other runtime libraries such as the + sanitizers. */ + +/* Emit a formatted error message to the standard output and then terminate the + process with an error code. */ + +void +_libga68_abort (const char *fmt, ...) +{ + va_list ap; + + va_start (ap, fmt); + vfprintf (stderr, fmt, ap); + abort (); + va_end (ap); +} + +/* Assertion failure. */ + +void +_libga68_assert (const char *filename, unsigned int lineno) +{ + _libga68_abort ("%s:%u: runtime error: ASSERT failure\n", + filename, lineno); +} + +/* Attempt to dereference NIL failure. */ + +void +_libga68_derefnil (const char *filename, unsigned int lineno) +{ + _libga68_abort ("%s:%u: runtime error: attempt to dereference NIL\n", + filename, lineno); +} + +/* Invalid character expression. */ + +void +_libga68_invalidcharerror (const char *filename, unsigned int lineno, + int c) +{ + if (c < 0) + _libga68_abort ("%s:%u: runtime error: %d is not a valid character point\n", + filename, lineno, c); + _libga68_abort ("%s:%u: runtime error: U+%x is not a valid character point\n", + filename, lineno, c); +} + +/* Out of bounds error in bits ELEM operator. */ + +void +_libga68_bitsboundserror (const char *filename, unsigned int lineno, + ssize_t pos) +{ + _libga68_abort ("%s:%u: runtime error: bound %zd out of range in ELEM\n", + filename, lineno, pos); +} + +/* Unreachable error. */ + +void +_libga68_unreachable (const char *filename, unsigned int lineno) +{ + _libga68_abort ("%s:%u: runtime error: unreachable reached\n", + filename, lineno); +} + +/* Lower bound failure. */ + +void +_libga68_lower_bound (const char *filename, unsigned int lineno, + ssize_t index, ssize_t lower_bound) +{ + _libga68_abort ("%s:%u: runtime error: lower bound %zd must be >= %zd\n", + filename, lineno, index, lower_bound); +} + +/* Upper bound failure. */ + +void +_libga68_upper_bound (const char *filename, unsigned int lineno, + ssize_t index, ssize_t upper_bound) +{ + _libga68_abort ("%s:%u: runtime error: upper bound %zd must be <= %zd\n", + filename, lineno, index, upper_bound); +} + +/* Bounds failure. */ + +void +_libga68_bounds (const char *filename, unsigned int lineno, + ssize_t index, ssize_t lower_bound, ssize_t upper_bound) +{ + _libga68_abort ("%s:%u: runtime error: bound %zd out of range [%zd:%zd]\n", + filename, lineno, index, lower_bound, upper_bound); +} + +/* Dimension failure. */ + +void +_libga68_dim (const char *filename, unsigned int lineno, + size_t dim, size_t index) +{ + _libga68_abort ("%s:%u: runtime error: invalid dimension %zd; shall be > 0 and <= %zu\n", + filename, lineno, index, dim); +} + +/* Multiples have different bounds in assignations. */ + +void +_libga68_bounds_mismatch (const char *filename, unsigned int lineno, + size_t dim, ssize_t lb1, ssize_t ub1, + ssize_t lb2, ssize_t ub2) +{ + _libga68_abort ("%s:%u: runtime error: multiple bounds mismatch in \ +assignation: dim %zu: [%zd:%zd] /= [%zd:%zd]\n", + filename, lineno, dim, lb1, ub1, lb2, ub2); +} diff --git a/libga68/ga68-posix.c b/libga68/ga68-posix.c new file mode 100644 index 000000000000..47038d6e39fd --- /dev/null +++ b/libga68/ga68-posix.c @@ -0,0 +1,463 @@ +/* Support run-time routines for the POSIX prelude. + + Copyright (C) 2025 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/>. */ + +#include "ga68.h" + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <fcntl.h> /* For open. */ +#include <unistd.h> /* For close and write. */ +#include <errno.h> /* For errno. */ +#include <sys/socket.h> +#include <sys/stat.h> /* For struct stat */ +#include <netinet/in.h> +#include <netdb.h> /* For gethostbyname. */ +#include <limits.h> /* For LLONG_MAX */ + +#define EOF_PSEUDO_CHARACTER -1 + +/* Some Unicode code points used in this file. */ + +#define REPLACEMENT_CHARACTER 0xFFFD +#define NEWLINE 0x000A + +/* Errno. */ + +static int _libga68_errno; + +/* Simple I/O based on POSIX file descriptors. */ + +int +_libga68_posixerrno (void) +{ + return _libga68_errno; +} + +void +_libga68_posixperror (uint32_t *s, size_t len, size_t stride) +{ + size_t u8len; + uint8_t *u8str = _libga68_u32_to_u8 (s, len, stride, NULL, &u8len); + + const char *errstr = strerror (_libga68_errno); + (void) write (2, u8str, u8len); + (void) write (2, ": ", 2); + (void) write (2, errstr, strlen (errstr)); + (void) write (2, "\n", 1); +} + +uint32_t * +_libga68_posixstrerror (int errnum, size_t *len) +{ + const char *str = strerror (errnum); + return _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, len); +} + +/* Helper for _libga68_posixfopen. */ +static int +_libga68_open (const char *path, unsigned int flags) +{ + int fd = open (path, flags); + _libga68_errno = errno; + 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 + +int +_libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride, + unsigned int flags) +{ + int fd; + int openflags = 0; + size_t u8len; + const uint8_t *u8pathname = _libga68_u32_to_u8 (pathname, len, stride, NULL, + &u8len); + char *filepath = (char *) _libga68_malloc_internal (u8len + 1); + memcpy (filepath, u8pathname, u8len); + filepath[u8len] = '\0'; + + /* 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) + { + openflags = O_RDWR; + if ((fd = _libga68_open (filepath, openflags)) < 0) + { + openflags = O_RDONLY; + if ((fd = _libga68_open (filepath, openflags)) < 0) + { + openflags = O_WRONLY; + fd = _libga68_open (filepath, openflags); + _libga68_free_internal (filepath); + return fd; + } + } + _libga68_free_internal (filepath); + return fd; + } + + if (flags & FILE_O_RDONLY) + openflags |= O_RDONLY; + if (flags & FILE_O_WRONLY) + openflags |= O_WRONLY; + if (flags & FILE_O_RDWR) + openflags |= O_RDWR; + if (flags & FILE_O_TRUNC) + openflags |= O_TRUNC; + + fd = _libga68_open (filepath, openflags); + _libga68_free_internal (filepath); + return fd; +} + +int +_libga68_posixcreat (uint32_t *pathname, size_t len, size_t stride, + uint32_t mode) +{ + size_t u8len; + uint8_t *u8pathname = _libga68_u32_to_u8 (pathname, len, stride, NULL, &u8len); + u8pathname[u8len] = '\0'; + + int res = creat (u8pathname, mode); + _libga68_errno = errno; + return res; +} + +int +_libga68_posixclose (int fd) +{ + int res = close (fd); + _libga68_errno = errno; + return res; +} + +/* Implementation of the posix prelude `posix argc'. */ + +int +_libga68_posixargc (void) +{ + return _libga68_argc; +} + +/* Implementation of the posix prelude `posix argv'. */ + +uint32_t * +_libga68_posixargv (int n, size_t *len) +{ + if (n < 0 || n > _libga68_argc) + { + /* Return an empty string. */ + *len = 0; + return NULL; + } + else + { + char *arg = _libga68_argv[n - 1]; + return _libga68_u8_to_u32 (arg, strlen (arg), NULL, len); + } +} + +/* Implementation of the posix prelude `posix getenv'. */ + +void +_libga68_posixgetenv (uint32_t *s, size_t len, size_t stride, + uint32_t **r, size_t *rlen) +{ + size_t varlen; + char *varname = _libga68_u32_to_u8 (s, len, stride, NULL, &varlen); + + char *var = _libga68_malloc_internal (varlen + 1); + memcpy (var, varname, varlen); + var[varlen] = '\0'; + char *val = getenv (var); + _libga68_free_internal (var); + + if (val == NULL) + { + /* Return an empty string. */ + *r = NULL; + *rlen = 0; + } + else + *r = _libga68_u8_to_u32 (val, strlen (val), NULL, rlen); +} + +/* Implementation of the posix prelude `posix puts'. */ + +void +_libga68_posixputs (uint32_t *s, size_t len, size_t stride) +{ + (void) _libga68_posixfputs (1, s, len, stride); +} + +/* Implementation of the posix prelude `posix fputs'. */ + +int +_libga68_posixfputs (int fd, uint32_t *s, size_t len, size_t stride) +{ + size_t u8len; + uint8_t *u8str = _libga68_u32_to_u8 (s, len, stride, NULL, &u8len); + + ssize_t ret = write (fd, u8str, u8len); + _libga68_errno = errno; + if (ret == -1) + return 0; + else + return u8len; +} + +/* Implementation of the posix prelude `posix putc'. */ + +uint32_t +_libga68_posixfputc (int fd, uint32_t c) +{ + uint8_t u8[6]; + + int u8len = _libga68_u8_uctomb (u8, c, 6); + if (u8len < 0) + return EOF_PSEUDO_CHARACTER; + + ssize_t ret = write (fd, &u8, u8len); + if (ret == -1) + return EOF_PSEUDO_CHARACTER; + else + return c; +} + +/* Implementation of the posix prelude `posix putchar'. */ + +uint32_t +_libga68_posixputchar (uint32_t c) +{ + return _libga68_posixfputc (1, c); +} + +/* Implementation of the posix prelude `posix fgetc'. */ + +uint32_t +_libga68_posixfgetc (int fd) +{ + /* We need to read one char (byte) at a time from FD, until we complete a + full Unicode character. Then we convert to UCS-4. */ + + uint8_t c; + uint8_t u8c[6]; + size_t morechars = 0; + size_t i; + + /* Read first UTF-8 character. This gives us the total length of the + character. */ + if (read (fd, &c, 1) != 1) + return EOF_PSEUDO_CHARACTER; + + if (c < 128) + morechars = 0; + else if (c < 224) + morechars = 1; + else if (c < 240) + morechars = 2; + else + morechars = 3; + + u8c[0] = c; + for (i = 0; i < morechars; ++i) + { + if (read (fd, &c, 1) != 1) + return EOF_PSEUDO_CHARACTER; + u8c[i + 1] = c; + } + + uint32_t res; + int num_units = morechars + 1; + int length = _libga68_u8_mbtouc (&res, (const uint8_t *) &u8c, num_units); + if (res == REPLACEMENT_CHARACTER || length != num_units) + return REPLACEMENT_CHARACTER; + else + return res; +} + +/* Implementation of the posix prelude `posix getchar'. */ + +uint32_t +_libga68_posixgetchar (void) +{ + return _libga68_posixfgetc (0); +} + +/* Implementation of the posix prelude `posix fgets'. */ + +uint32_t * +_libga68_posixfgets (int fd, int nchars, size_t *len) +{ + uint32_t *res = NULL; + int n = 0; + uint32_t uc; + + if (nchars > 0) + { + /* Read exactly nchar or until EOF. */ + res = _libga68_malloc (nchars * sizeof (uint32_t)); + do + { + uc = _libga68_posixfgetc (fd); + if (uc == EOF_PSEUDO_CHARACTER) + break; + res[n++] = uc; + } + while (n < nchars); + } + else + { + /* Read until newline or EOF. */ + size_t allocated = 80 * sizeof (uint32_t); + res = _libga68_malloc (allocated); + do + { + uc = _libga68_posixfgetc (fd); + if (uc != EOF_PSEUDO_CHARACTER) + { + if (n % 80 == 0) + res = _libga68_realloc (res, n * 80 * sizeof (uint32_t) + 80 * sizeof (uint32_t)); + res[n++] = uc; + } + } + while (uc != NEWLINE && uc != EOF_PSEUDO_CHARACTER); + if (n > 0) + res = _libga68_realloc (res, n * 80 * sizeof (uint32_t)); + } + + *len = n; + return res; +} + +/* Implementation of the posix prelude `posix gets'. */ + +uint32_t * +_libga68_posixgets (int nchars, size_t *len) +{ + return _libga68_posixfgets (0, nchars, len); +} + +/* Implementation of the posix prelude `fconnect'. */ + +int +_libga68_posixfconnect (uint32_t *str, size_t len, size_t stride, + int port) +{ + size_t u8len; + uint8_t *u8host = _libga68_u32_to_u8 (str, len, stride, NULL, &u8len); + + /* Create a stream socket. */ + int fd = socket (AF_INET, SOCK_STREAM, 0); + _libga68_errno = errno; + if (fd < 0) + goto error; + + /* Lookup the specified host. */ + char *host = _libga68_malloc_internal (u8len + 1); + memcpy (host, u8host, u8len); + host[u8len] = '\0'; + struct hostent *server = gethostbyname (host); + if (server == NULL) + { + _libga68_errno = h_errno; + goto close_fd_and_error; + } + + /* Connect the socket to the server. */ + struct sockaddr_in serv_addr; + memset (&serv_addr, 0, sizeof (serv_addr)); + serv_addr.sin_family = AF_INET; + serv_addr.sin_port = htons (port); + memcpy (&serv_addr.sin_addr.s_addr, + server->h_addr, + server->h_length); + int res = connect (fd, (struct sockaddr *) &serv_addr, + sizeof (serv_addr)); + _libga68_errno = errno; + if (res == -1) + goto close_fd_and_error; + + _libga68_free_internal (host); + return fd; + + close_fd_and_error: + close (fd); + error: + _libga68_free_internal (host); + return -1; +} + +/* Implementation of the posix prelude `fsize'. */ + +long long int +_libga68_posixfsize (int fd) +{ + struct stat stat; + + if (fstat (fd, &stat) == -1) + { + _libga68_errno = errno; + return -1; + } + + if (stat.st_size > LLONG_MAX) + { + _libga68_errno = EOVERFLOW; + return -1; + } + + return (long int) stat.st_size; +} + +/* Implementation of the posix prelude `lseek'. */ +#define A68_SEEK_CUR 0 +#define A68_SEEK_END 1 +#define A68_SEEK_SET 2 + +long long int +_libga68_posixlseek (int fd, long long int offset, int whence) +{ + switch (whence) + { + case A68_SEEK_CUR: + whence = SEEK_CUR; + break; + case A68_SEEK_END: + whence = SEEK_END; + break; + case A68_SEEK_SET: + whence = SEEK_SET; + break; + } + + long long int ret = (long long int) lseek(fd, offset, whence); + _libga68_errno = errno; + return ret; +} diff --git a/libga68/ga68-standenv.c b/libga68/ga68-standenv.c new file mode 100644 index 000000000000..2c1b7979af10 --- /dev/null +++ b/libga68/ga68-standenv.c @@ -0,0 +1,48 @@ +/* Support run-time routines for the standard prelude. + + Copyright (C) 2025 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/>. */ + +#include <stdlib.h> /* For rand. */ + +#include "ga68.h" + +/* Implementation of the standard prelude `random' function. */ + +float +_libga68_random (void) +{ + float res = (float) rand () / (float) (RAND_MAX); + return res; +} + +double +_libga68_longrandom (void) +{ + double res = (double) rand () / (float) (RAND_MAX); + return res; +} + +long double +_libga68_longlongrandom (void) +{ + long double res = (long double) rand () / (float) (RAND_MAX); + return res; +} diff --git a/libga68/ga68-unistr.c b/libga68/ga68-unistr.c new file mode 100644 index 000000000000..7f2cb97de70b --- /dev/null +++ b/libga68/ga68-unistr.c @@ -0,0 +1,615 @@ +/* libga68 unicode support routines. + Copyright (C) 2009-2025 Free Software Foundation, Inc. + Copyright (C) 2025 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/>. */ + +/* The code in this file has been copied from the unistr gnulib module, written + by Bruno Haible, and adapted to support strides. */ + +#include <stddef.h> /* For ptrdiff_t */ +#include <stdlib.h> +#include <stdint.h> +#include <errno.h> +#include <string.h> + +#include "ga68.h" + +/* CMP (n1, n2) performs a three-valued comparison on n1 vs. n2, where + n1 and n2 are expressions without side effects, that evaluate to real + numbers (excluding NaN). + It returns + 1 if n1 > n2 + 0 if n1 == n2 + -1 if n1 < n2 + The naïve code (n1 > n2 ? 1 : n1 < n2 ? -1 : 0) produces a conditional + jump with nearly all GCC versions up to GCC 10. + This variant (n1 < n2 ? -1 : n1 > n2) produces a conditional with many + GCC versions up to GCC 9. + The better code (n1 > n2) - (n1 < n2) from Hacker's Delight § 2-9 + avoids conditional jumps in all GCC versions >= 3.4. */ + +#define CMP(n1, n2) (((n1) > (n2)) - ((n1) < (n2))) + +/* MIN(a,b) returns the minimum of A and B. */ + +#ifndef MIN +# define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +/* Compare two UCS-4 strings of same lenght, lexicographically. + Return -1, 0 or 1. */ + +int +_libga68_u32_cmp (const uint32_t *s1, size_t stride1, + const uint32_t *s2, size_t stride2, + size_t n) +{ + stride1 = stride1 / sizeof (uint32_t); + stride2 = stride2 / sizeof (uint32_t); + + for (; n > 0;) + { + uint32_t uc1 = *s1; + s1 += stride1; + uint32_t uc2 = *s2; + s2 += stride2; + if (uc1 == uc2) + { + n--; + continue; + } + /* Note that uc1 and uc2 each have at most 31 bits. */ + return (int)uc1 - (int)uc2; + /* > 0 if uc1 > uc2, < 0 if uc1 < uc2. */ + } + return 0; +} + +/* Compare two UCS-4 strings of perhaps different lenghts, lexicographically. + Return -1, 0 or 1. */ + +int +_libga68_u32_cmp2 (const uint32_t *s1, size_t n1, size_t stride1, + const uint32_t *s2, size_t n2, size_t stride2) +{ + int cmp = _libga68_u32_cmp (s1, stride1, s2, stride2, MIN (n1, n2)); + + if (cmp == 0) + cmp = CMP (n1, n2); + + return cmp; +} + +/* Get the UCS code for the first character of a given UTF-8 string. */ + +int +_libga68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return 1; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + if ((s[2] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 2; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; + } + else + { + *puc = 0xfffd; + if (n == 1) + { + /* incomplete multibyte character */ + return 1; + } + else + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + /* incomplete multibyte character */ + return 2; + } + else + { + /* invalid multibyte character */ + return 1; + } + } + } + } + else if (c <= 0xf4) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if ((s[2] ^ 0x80) < 0x40) + { + if ((s[3] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 3; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 2; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; + } + else + { + *puc = 0xfffd; + if (n == 1) + { + /* incomplete multibyte character */ + return 1; + } + else + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if (n == 2) + { + /* incomplete multibyte character */ + return 2; + } + else + { + if ((s[2] ^ 0x80) < 0x40) + { + /* incomplete multibyte character */ + return 3; + } + else + { + /* invalid multibyte character */ + return 2; + } + } + } + else + { + /* invalid multibyte character */ + return 1; + } + } + } + } + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +/* Encode a given UCS code in UTF-8. */ + +int +_libga68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n) +{ + if (uc < 0x80) + { + if (n > 0) + { + s[0] = uc; + return 1; + } + /* else return -2, below. */ + } + else + { + int count; + + if (uc < 0x800) + count = 2; + else if (uc < 0x10000) + { + if (uc < 0xd800 || uc >= 0xe000) + count = 3; + else + return -1; + } + else if (uc < 0x110000) + count = 4; + else + return -1; + + if (n >= count) + { + switch (count) /* note: code falls through cases! */ + { + case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; + /* Fallthrough. */ + case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; + /* Fallthrough. */ + case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; + /*case 1:*/ s[0] = uc; + } + return count; + } + } + return -2; +} + +/* Convert UCS-4 to UTF-8 */ + +uint8_t * +_libga68_u32_to_u8 (const uint32_t *s, size_t n, size_t stride, + uint8_t *resultbuf, size_t *lengthp) +{ + const uint32_t *s_end; + /* Output string accumulator. */ + uint8_t *result; + size_t allocated; + size_t length; + + stride = stride / sizeof (uint32_t); + s_end = s + (n * stride); + + if (resultbuf != NULL) + { + result = resultbuf; + allocated = *lengthp; + } + else + { + result = NULL; + allocated = 0; + } + length = 0; + /* Invariants: + result is either == resultbuf or == NULL or malloc-allocated. + If length > 0, then result != NULL. */ + + while (s < s_end) + { + uint32_t uc; + int count; + + /* Fetch a Unicode character from the input string. */ + uc = *s; + s += stride; + /* No need to call the safe variant u32_mbtouc, because + u8_uctomb will verify uc anyway. */ + + /* Store it in the output string. */ + count = _libga68_u8_uctomb (result + length, uc, allocated - length); + if (count == -1) + { + if (!(result == resultbuf || result == NULL)) + free (result); + errno = EILSEQ; + return NULL; + } + if (count == -2) + { + uint8_t *memory; + + allocated = (allocated > 0 ? 2 * allocated : 12); + if (length + 6 > allocated) + allocated = length + 6; + if (result == resultbuf || result == NULL) + memory = (uint8_t *) _libga68_malloc (allocated * sizeof (uint8_t)); + else + memory = + (uint8_t *) _libga68_realloc (result, allocated * sizeof (uint8_t)); + + if (result == resultbuf && length > 0) + memcpy ((char *) memory, (char *) result, + length * sizeof (uint8_t)); + result = memory; + count = _libga68_u8_uctomb (result + length, uc, allocated - length); + if (count < 0) + abort (); + } + length += count; + } + + if (length == 0) + { + if (result == NULL) + { + /* Return a non-NULL value. NULL means error. */ + result = (uint8_t *) _libga68_malloc (1); + if (result == NULL) + { + errno = ENOMEM; + return NULL; + } + } + } + else if (result != resultbuf && length < allocated) + { + /* Shrink the allocated memory if possible. */ + uint8_t *memory; + + memory = (uint8_t *) _libga68_realloc_unchecked (result, length * sizeof (uint8_t)); + if (memory != NULL) + result = memory; + } + + *lengthp = length; + return result; +} + +/* Used by ga68_u8_to_u32 below. */ + +static int +_libga68_u8_mbtoucr (uint32_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c < 0xf0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c <= 0xf4) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + if (n >= 4) + { + if ((s[3] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + } + /* invalid multibyte character */ + *puc = 0xfffd; + return -1; +} + +/* Convert UTF-8 to UTF-32/UCS-4 */ + +uint32_t * +_libga68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp) +{ + const uint8_t *s_end = s + n; + /* Output string accumulator. */ + uint32_t *result; + size_t allocated; + size_t length; + + if (resultbuf != NULL) + { + result = resultbuf; + allocated = *lengthp; + } + else + { + result = NULL; + allocated = 0; + } + length = 0; + /* Invariants: + result is either == resultbuf or == NULL or malloc-allocated. + If length > 0, then result != NULL. */ + + while (s < s_end) + { + uint32_t uc; + int count; + + /* Fetch a Unicode character from the input string. */ + count = _libga68_u8_mbtoucr (&uc, s, s_end - s); + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + errno = EILSEQ; + return NULL; + } + s += count; + + /* Store it in the output string. */ + if (length + 1 > allocated) + { + uint32_t *memory; + + allocated = (allocated > 0 ? 2 * allocated : 12); + if (length + 1 > allocated) + allocated = length + 1; + if (result == resultbuf || result == NULL) + memory = (uint32_t *) _libga68_malloc (allocated * sizeof (uint32_t)); + else + memory = + (uint32_t *) _libga68_realloc (result, allocated * sizeof (uint32_t)); + + if (result == resultbuf && length > 0) + memcpy ((char *) memory, (char *) result, + length * sizeof (uint32_t)); + result = memory; + } + result[length++] = uc; + } + + if (length == 0) + { + if (result == NULL) + { + /* Return a non-NULL value. NULL means error. */ + result = (uint32_t *) _libga68_malloc (1); + } + } + else if (result != resultbuf && length < allocated) + { + /* Shrink the allocated memory if possible. */ + uint32_t *memory; + + memory = (uint32_t *) _libga68_realloc_unchecked (result, length * sizeof (uint32_t)); + if (memory != NULL) + result = memory; + } + + *lengthp = length; + return result; +} diff --git a/libga68/ga68.h b/libga68/ga68.h new file mode 100644 index 000000000000..764ea2b3ce79 --- /dev/null +++ b/libga68/ga68.h @@ -0,0 +1,126 @@ +/* Definitions for libga68. + Copyright (C) 2025 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/>. */ + +#ifndef GA68_H +#define GA68_H + +#include "config.h" + +#include <stddef.h> /* For size_t. */ +#include <stdint.h> +#include <stdarg.h> +#ifdef __has_include +# if __has_include (<sys/types.h>) +# include <sys/types.h> /* For ssize_t. */ +# endif +#endif + +/* ga68-error.c */ + +void _libga68_abort (const char *fmt, ...) + __attribute__ ((__format__ (__printf__, 1, 2), __nonnull__ (1), + __noreturn__)); + +void _libga68_assert (const char *filename, unsigned int lineno); +void _libga68_derefnil (const char *filename, unsigned int lineno); +void _libga68_invalidcharerror (const char *filename, unsigned int lineno, + int c); + +void _libga68_bitsboundserror (const char *filename, unsigned int lineno, + ssize_t pos); +void _libga68_unreachable (const char *filename, unsigned int lineno); +void _libga68_lower_bound (const char *filename, unsigned int lineno, + ssize_t index, ssize_t lower_bound); +void _libga68_upper_bound (const char *filename, unsigned int lineno, + ssize_t index, ssize_t upper_bound); +void _libga68_bounds (const char *filename, unsigned int lineno, + ssize_t index, ssize_t lower_bound, ssize_t upper_bound); +void _libga68_dim (const char *filename, unsigned int lineno, + size_t dim, size_t index); +void _libga68_bounds_mismatch (const char *filename, unsigned int lineno, + size_t dim, ssize_t lb1, ssize_t ub1, + ssize_t lb2, ssize_t ub2); + +/* ga68-alloc.c */ + +void _libga68_init_heap (void); +void *_libga68_malloc (size_t size); +void *_libga68_malloc_internal (size_t size); +void *_libga68_realloc (void *ptr, size_t size); +void *_libga68_realloc_unchecked (void *ptr, size_t size); +void _libga68_free_internal (void *ptr); + +/* ga68-standenv.c */ + +float _libga68_random (void); +double _libga68_longrandom (void); +long double _libga68_longlongrandom (void); + +/* ga68-posix.c */ + +int _libga68_posixerrno (void); +void _libga68_posixperror (uint32_t *s, size_t len, size_t stride); +uint32_t *_libga68_posixstrerror (int errnum, size_t *len); +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_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); +uint32_t _libga68_posixputchar (uint32_t c); +uint32_t _libga68_posixfputc (int fd, uint32_t c); +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); + +int _libga68_posixfconnect (uint32_t *str, size_t len, size_t stride, + int port); +long long int _libga68_posixlseek (int fd, long long int offset, int whence); + +/* ga68-unistr.c */ + +int _libga68_u32_cmp (const uint32_t *s1, size_t stride1, + const uint32_t *s2, size_t stride2, + size_t n); +int _libga68_u32_cmp2 (const uint32_t *s1, size_t n1, size_t stride1, + const uint32_t *s2, size_t n2, size_t stride2); +int _libga68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n); +int _libga68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n); +uint8_t *_libga68_u32_to_u8 (const uint32_t *s, size_t n, size_t stride, + uint8_t *resultbuf, size_t *lengthp); +uint32_t *_libga68_u8_to_u32 (const uint8_t *s, size_t n, + uint32_t *resultbuf, size_t *lengthp); + +/* libga68.c */ + +extern int _libga68_argc; +extern char **_libga68_argv; + +void _libga68_set_exit_status (int status); + +#endif /* ! GA68_H */ diff --git a/libga68/libga68.c b/libga68/libga68.c new file mode 100644 index 000000000000..60f930a53334 --- /dev/null +++ b/libga68/libga68.c @@ -0,0 +1,52 @@ +/* GNU Algol Compiler run-time. + Copyright (C) 2025 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/>. */ + +#include "ga68.h" + +/* argc and argv are preserved in the following objects. */ + +int _libga68_argc; +char **_libga68_argv; + +/* Exit status of the program reported to the OS upon exit. */ + +static int exit_status; + +void +_libga68_set_exit_status (int status) +{ + exit_status = status; +} + +/* Entry point for Algol 68 programs. */ + +void __algol68_main (void); + +int +main (int argc, char **argv) +{ + _libga68_argc = argc; + _libga68_argv = argv; + + _libga68_init_heap (); + __algol68_main (); + return exit_status; +} diff --git a/libga68/libga68.spec.in b/libga68/libga68.spec.in new file mode 100644 index 000000000000..7b09f655a2b4 --- /dev/null +++ b/libga68/libga68.spec.in @@ -0,0 +1,11 @@ +# +# This spec file is read by ga68 when linking. +# It is used to specify the libraries we need to link in, in the right +# order. +# + +%rename link linkorig_ga68_renamed +*link: %(linkorig_ga68_renamed) + +%rename lib liborig_ga68_renamed +*lib: %{noga68lib: ; :@SPEC_LIBGA68_DEPS@} %(liborig_ga68_renamed)
