TeamHeptaMirrors/gcc
1
0
Fork 1
mirror of https://github.com/gcc-mirror/gcc.git synced 2026-05-06 14:59:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

a68: libga68: sources, spec and misc files

Browse Source 
Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>

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.
This commit is contained in:
Jose E. Marchesi
2025-10-11 19:54:57 +02:00
parent 1150e6de75
commit b67e045af7
9 changed files with 1582 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
libga68/README Normal file
View File

@@ -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.

114
libga68/ga68-alloc.c Normal file
View File

@@ -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 */

151
libga68/ga68-error.c Normal file
View File

@@ -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);
}

463
libga68/ga68-posix.c Normal file
View File

@@ -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;
}

48
libga68/ga68-standenv.c Normal file
View File

@@ -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;
}

615
libga68/ga68-unistr.c Normal file
View File

@@ -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;
}

126
libga68/ga68.h Normal file
View File

@@ -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 */

52
libga68/libga68.c Normal file
View File

@@ -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;
}

11
libga68/libga68.spec.in Normal file
View File

@@ -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)