/*
* $Id: routine.c,v 1.4 2025/03/27 03:27:35 snw Exp $
* Routine buffer management
*
*
* Author: Serena Willis <snw@coherent-logic.com>
* Copyright (C) 1998 MUG Deutschland
* Copyright (C) 2023, 2025 Coherent Logic Development LLC
*
*
* This file is part of FreeM.
*
* FreeM is free software: you can redistribute it and/or modify
* it under the terms of the GNU Affero Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* FreeM 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 Affero Public License for more details.
*
* You should have received a copy of the GNU Affero Public License
* along with FreeM. If not, see <https://www.gnu.org/licenses/>.
*
* $Log: routine.c,v $
* Revision 1.4 2025/03/27 03:27:35 snw
* Install init scripts to share/freem/examples/init and fix regression in method dispatch
*
* Revision 1.3 2025/03/09 19:50:47 snw
* Second phase of REUSE compliance and header reformat
*
*
* SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
* SPDX-License-Identifier: AGPL-3.0-or-later
**/
#include <string.h>
#include <errno.h>
#include <sys/types.h>
#if !defined(__OpenBSD__) && !defined(__FreeBSD__)
# include <sys/timeb.h>
#endif
#include <sys/ioctl.h>
#include <unistd.h>
#include <stdlib.h>
#include <ctype.h>
#ifdef AMIGA68K
#include <sys/fcntl.h>
#endif
#include "mpsdef.h"
#include <time.h>
#ifdef USE_SYS_TIME_H
#include <sys/time.h>
#endif
#include "events.h"
short rtn_get_offset(char *buf)
{
char *rp;
char *rc;
char *p;
char otag[256];
char ortn[256];
char oline[256];
register int i = 0;
register int j = 0;
register int k = 0;
int os = 0;
stcpy (ortn, rou_name);
rp = rouptr;
rc = roucur;
stcnv_m2c (ortn);
while (rp < rc) {
i = 0;
for (p = rp + 1; p < rc && *p != EOL && *p != '\0'; p++) {
if (i < 256) {
oline[i++] = *p;
}
}
oline[i] = '\0';
if (isalpha (oline[0]) || oline[0] == '%') {
os = 0;
k = 0;
for (j = 0; j < strlen (oline); j++) {
switch (oline[j]) {
case ' ':
case '(':
case ';':
case EOL:
otag[k] = '\0';
break;
default:
otag[k++] = oline[j];
}
if (oline[j] == ' ' || oline[j] == '(' || oline[j] == ';' || oline[j] == EOL) break;
}
}
else {
os++;
}
rp = p + 1;
}
if (os) {
sprintf (buf, "%s+%d^%s\201", otag, os, ortn);
}
else {
sprintf (buf, "%s^%s\201", otag, ortn);
}
return TRUE;
}
char *rtn_resolve(char *rou, char *tag, char *buf)
{
char superclass[255];
if (rtn_has_tag (rou, tag)) {
strcpy (buf, rou);
return buf;
}
else {
if (rtn_get_superclass (rou, superclass)) {
return rtn_resolve (superclass, tag, buf);
}
else {
buf = NULL;
return NULL;
}
}
}
short rtn_get_superclass(char *rou, char *buf)
{
FILE *fp;
char pth[PATHLEN];
char line[255];
char *s;
short rtn_exists;
short after_parens;
short found_super;
char *p;
register char ch;
if (strcmp (rou, "%OBJECT") == 0) {
buf = NULL;
return FALSE;
}
rtn_exists = rtn_get_path (rou, pth);
if (rtn_exists == FALSE) {
buf = NULL;
return FALSE;
}
fp = fopen (pth, "r");
if (fp == NULL) {
buf = NULL;
return FALSE;
}
s = fgets (line, 255, fp);
fclose (fp);
if (s == NULL) {
buf = NULL;
return FALSE;
}
if ((!isalpha (line[0])) && (line[0] != '%')) {
buf = NULL;
return FALSE;
}
p = line;
after_parens = FALSE;
found_super = FALSE;
while ((ch = *p++) != '\0') {
if (ch == ')') after_parens = TRUE;
/* ignore comments in search for superclass */
if (ch == ';' && after_parens == TRUE) {
found_super = FALSE;
break;
}
if (ch == ':' && after_parens == TRUE) {
strcpy (buf, p);
found_super = TRUE;
break;
}
}
if (!found_super) {
sprintf (buf, "%%OBJECT");
return TRUE;
}
p = buf;
for (;;) {
ch = *p;
if (ch == SP || ch == TAB || ch == ';' || ch == '\0' || ch == '\r' || ch == '\n') {
*p = '\0';
break;
}
p++;
}
return TRUE;
}
short rtn_get_path(char *rou, char *buf)
{
FILE *fp;
char pth[PATHLEN];
if (rou[0] == '%') {
stcpy (pth, rou0plib);
stcnv_m2c (pth);
}
else {
stcpy (pth, rou0path);
stcnv_m2c (pth);
}
snprintf (buf, PATHLEN, "%s/%s.m", pth, rou);
if ((fp = fopen (buf, "r")) != NULL) {
(void) fclose (fp);
return TRUE;
}
else {
return FALSE;
}
}
short rtn_has_tag(char *rou, char *tag)
{
m_entry *entries;
m_entry *e;
entries = rtn_get_entries (rou);
for (e = entries; e != NULL; e = e->next) {
if (strcmp (tag, e->tag) == 0) {
rtn_free_entries (entries);
return TRUE;
}
}
rtn_free_entries (entries);
return FALSE;
}
void rtn_free_entries(m_entry *head)
{
m_entry *tmp;
while (head != NULL) {
tmp = head;
head = head->next;
free (tmp);
}
head = NULL;
}
m_entry *rtn_get_entries(char *rou)
{
FILE *fp;
char rou_path[PATHLEN];
m_entry *head = NULL;
m_entry *t;
register char ch;
register int i = 0;
register int j = 0;
char cur_line[255];
char cur_label[255];
int has_args = 0;
char *paren_pos;
char *curarg;
if (rtn_get_path (rou, rou_path) == FALSE) {
return (m_entry *) NULL;
}
fp = fopen (rou_path, "r");
while (fgets (cur_line, 255, fp) != NULL) {
if (isalpha (cur_line[0]) || cur_line[0] == '%') {
has_args = 0;
j = 0;
for (i = 0; i < strlen (cur_line); i++) {
ch = cur_line[i];
switch (ch) {
case ')':
cur_label[j++] = ')';
case SP:
case TAB:
case EOL:
cur_label[j] = '\0';
j = 0;
if (strlen (cur_label)) {
t = (m_entry *) malloc (sizeof (m_entry));
NULLPTRCHK(t,"rtn_get_entries");
paren_pos = strchr (cur_label, '(');
if (paren_pos == NULL) {
/* not a formallist */
t->tag = (char *) malloc (sizeof (char) * (strlen (cur_label) + 1));
NULLPTRCHK(t->tag,"rtn_get_entries");
strcpy (t->tag, cur_label);
}
else {
/* a formallist */
char *toktmp;
toktmp = strdup (cur_label);
NULLPTRCHK(toktmp,"rtn_get_entries");
(void) strtok (toktmp, "(");
t->tag = malloc (sizeof (char) * (strlen (toktmp) + 1));
NULLPTRCHK(t->tag,"rtn_get_entries");
strcpy (t->tag, toktmp);
free (toktmp);
}
t->next = head;
head = t;
}
break;
case '(':
has_args++;
default:
cur_label[j++] = ch;
}
if (ch == SP || ch == TAB || ch == EOL) break;
}
}
}
fclose (fp);
return head;
}
void zload (char *rou) /* load routine in buffer */
{
FILE *infile;
short linelen;
char pgm[256];
char tmp1[256];
register long int i;
register long int j;
register long int ch;
char *savptr; /* save routine pointer */
long timex;
short altern = 0;
/* Routines are stored in routine buffers. If a routine is called
* we first look whether it's already loaded. If not, we look for
* the least recently used buffer and load it there. Besides
* dramatically improved performance there is little effect on
* the user. Sometimes you see an effect: if the program is changed
* by some other user or by yourself using the 'ced' editor you
* may get the old version for some time with DO, GOTO or ZLOAD.
* A ZREMOVE makes sure the routine is loaded from disk.
*/
if (*rou == EOL || *rou == 0) { /* routine name empty */
pgms[0][0] = EOL;
rouend = rouins = rouptr = buff;
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
*rouptr = EOL;
*(rouptr + 1) = EOL;
*(rouptr + 2) = EOL;
dosave[0] = 0;
return;
}
savptr = rouptr;
/* what time is it ? */
timex = time (0L);
/* FreeM: it takes a lickin' and keeps on tickin' */
/* let's have a look whether we already have the stuff */
for (i = 0; i < NO_OF_RBUF; i++) {
if (pgms[i][0] == 0) {
altern = i;
break;
} /* buffer empty */
j = 0;
while (rou[j] == pgms[i][j]) {
if (rou[j++] == EOL) {
rouptr = buff + (i * PSIZE0);
ages[i] = time (0L);
rouend = ends[i];
rouins = rouend - 1;
return;
}
}
if (ages[i] <= timex) timex = ages[altern = i];
}
/* clear DO-label stored under FOR */
dosave[0] = 0;
j = 0;
ch = EOL; /* init for multiple path search */
tmp1[0] = EOL;
nextpath: /* entry point for retry */
i = 0;
if (rou[0] == '%') { /* %_routines are in special directory */
if (mcmnd >= 'a') { /* DO GOTO JOB */
if (rou0plib[j] != EOL) {
while ((ch = pgm[i++] = rou0plib[j++]) != ':' && ch != EOL);
}
}
else if (rou1plib[j] != EOL) {
while ((ch = pgm[i++] = rou1plib[j++]) != ':' && ch != EOL);
}
}
else {
if (mcmnd >= 'a') { /* DO GOTO JOB */
if (rou0path[j] != EOL) {
while ((ch = pgm[i++] = rou0path[j++]) != ':' && ch != EOL);
}
}
else if (rou1path[j] != EOL) {
while ((ch = pgm[i++] = rou1path[j++]) != ':' && ch != EOL);
}
}
if (i > 0) {
if (i == 1 || (i == 2 && pgm[0] == '.')) {
i = 0;
}
else {
pgm[i - 1] = '/';
}
}
pgm[i] = EOL;
stcpy (tmp1, pgm); /* directory where we search for the routine */
stcpy (&pgm[i], rou);
rouptr = buff + (altern * PSIZE0);
stcat (pgm, rou_ext);
pgm[stlen (pgm)] = NUL; /* append routine extension */
if ((infile = fopen (pgm, "r")) == NULL) {
rouptr = savptr;
if (ch != EOL) goto nextpath; /* try next access path */
stcpy (varerr, rou);
merr_raise (NOPGM);
return;
}
again:
linelen = 0;
savptr = rouend = rouptr;
for (i = 1; i < (PSIZE0 - 1); i++) {
*++rouend = ch = getc (infile);
if (ch == LF || ch == EOF) {
*rouend++ = EOL;
i++;
*savptr = i - linelen - 2;
savptr = rouend;
linelen = i;
if (ch == EOF) {
fclose (infile);
*rouend-- = EOL;
rouins = rouend - 1;
ends[altern] = rouend;
ages[altern] = time (0L);
stcpy (pgms[altern], rou);
stcpy (path[altern], tmp1);
rbuf_flags[altern].dialect = standard;
if (standard == D_FREEM) {
rbuf_flags[altern].standard = FALSE;
}
else {
rbuf_flags[altern].standard = TRUE;
}
return;
}
}
}
rouptr = savptr;
if (autorsize) {
while ((ch = getc (infile)) != EOF) {
i++;
if (ch == LF) i++;
} /* how big? */
i = ((i + 3) & ~01777) + 02000; /* round for full kB; */
if (newrsize (i, NO_OF_RBUF) == 0) { /* try to get more routine space. */
altern = 0;
ch = EOL;
fseek (infile, 0L, 0);
goto again;
}
}
fclose (infile);
goto pgmov;
pgmov:
/* program overflow error */
rouptr = rouins = rouend = savptr;
(*savptr++) = EOL;
*savptr = EOL;
for (i = 0; i < NO_OF_RBUF; i++) {
ages[i] = 0;
pgms[i][0] = 0;
}
pgms[i][0] = EOL;
rou_name[0] = EOL;
merr_raise (PGMOV);
return;
} /* end of zload() */
void zsave (char *rou) /* save routine on disk */
{
register int i;
register int j;
register int ch;
char tmp[256];
stcpy (tmp, rou); /* save name without path */
/* look whether we know where the routine came from */
if (zsavestrategy) { /* VIEW 133: remember ZLOAD directory on ZSAVE */
for (i = 0; i < NO_OF_RBUF; i++) {
if (pgms[i][0] == 0) break; /* buffer empty */
j = 0;
while (rou[j] == pgms[i][j]) {
if (rou[j++] == EOL) {
stcpy (rou, path[i]);
stcat (rou, tmp);
j = 0;
ch = 1; /* init for multiple path search */
goto try;
}
}
}
}
/* not found */
j = 0;
ch = EOL; /* init for multiple path search */
nextpath: /* entry point for retry */
if (tmp[0] == '%') {
if (rou1plib[0] != EOL) {
i = 0;
while ((ch = rou[i++] = rou1plib[j++]) != ':' && ch != EOL);
if (i == 1 || (i == 2 && rou[0] == '.')) {
i = 0;
}
else {
rou[i - 1] = '/';
}
stcpy (&rou[i], tmp);
}
}
else {
if (rou1path[0] != EOL) {
i = 0;
while ((ch = rou[i++] = rou1path[j++]) != ':' && ch != EOL);
if (i == 1 || (i == 2 && rou[0] == '.')) {
i = 0;
}
else {
rou[i - 1] = '/';
}
stcpy (&rou[i], tmp);
}
}
try:
stcat (rou, rou_ext);
rou[stlen (rou)] = NUL; /* append routine extention */
if (rouend <= rouptr) {
unlink (rou);
rou_name[0] = EOL;
}
else {
FILE *outfile;
char *i0;
for (;;) {
errno = 0;
if ((outfile = fopen (rou, "w")) != NULL) break;
if (errno == EINTR) continue; /* interrupt */
if (errno == EMFILE || errno == ENFILE) {
close_all_globals ();
continue;
} /* free file_des */
if (ch != EOL) goto nextpath; /* try next access path */
merr_raise (PROTECT);
return;
}
i0 = rouptr;
while (++i0 < (rouend - 1)) {
if ((ch = (*(i0))) == EOL) {
ch = LF;
i0++;
}
putc (ch, outfile);
}
if (ch != LF) putc (LF, outfile);
fclose (outfile);
}
return;
} /* end of zsave() */
/* insert 'line' in routine at 'position' */
void zi (char *line, char *position)
{
short offset;
short label;
short i;
short i0;
short ch;
char *reg;
char *end;
char line0[256];
if (rouend - rouptr + stlen (line) + 1 > PSIZE0) { /* sufficient space ??? */
reg = buff;
if (getrmore () == 0L) return; /* PGMOV */
position += buff - reg;
}
label = TRUE;
i = 0;
i0 = 0;
while ((ch = line[i]) != EOL) {
if (label) {
if (ch == SP) ch = TAB;
if (ch == TAB) {
label = FALSE;
}
else if (ch == '(') {
line0[i0++] = ch;
i++;
while (((ch = line[i]) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '%' || ch == ',') {
line0[i0++] = ch;
i++;
}
if (ch != ')') {
merr_raise (ISYNTX);
return;
}
line0[i0++] = ch;
i++;
if ((ch = line[i]) != SP && ch != TAB) {
merr_raise (ISYNTX);
return;
}
continue;
}
else if ((ch < 'a' || ch > 'z') && (ch < 'A' || ch > 'Z') && (ch < '0' || ch > '9') && (ch != '%' || i)) {
merr_raise (ISYNTX);
return;
}
line0[i0++] = ch;
i++;
continue;
}
if (ch < SP || (ch >= DEL && (eightbit == FALSE))) {
merr_raise (ISYNTX);
return;
}
line0[i0++] = ch;
i++;
}
if (label) {
merr_raise (ISYNTX);
return;
}
line0[i0] = EOL;
offset = i0;
if (offset > 0) {
offset += 2;
end = rouend;
rouend += offset;
if (roucur > position || roucur > end) roucur += offset;
reg = rouend;
while (position <= end) {
(*reg--) = (*end--);
}
(*(position++)) = (UNSIGN (offset) - 2);
reg = line0;
while (((*(position++)) = (*(reg++))) != EOL);
*(rouend + 1) = EOL;
*(rouend + 2) = EOL;
for (i = 0; i < NO_OF_RBUF; i++) {
if (rouptr == (buff + (i * PSIZE0))) {
ends[i] = rouend;
break;
}
}
}
rouins = position;
return;
} /* end of zi() */
/*
* getraddress(char *a, short lvl):
*
* returns the 'canonical' address of the line at the specified DO/FOR/XEC level
*
* char *a (out param): pointer to the address of the line
* short lvl: process this level
*
*/
void getraddress (char *a, short lvl)
{
char *rcur; /* cursor into routine */
short f;
char tmp3[256];
char *j0;
char *j1;
short rlvl; /* lower level, where to find routine name */
register int i;
register int j;
f = mcmnd;
mcmnd = 'd'; /* make load use standard-path */
rlvl = lvl;
if (nestn[rlvl] == 0 && rlvl < nstx) rlvl++;
if (nestn[rlvl]) zload (nestn[rlvl]);
mcmnd = f;
/* command on stack: 2 == DO_BLOCK; other: make uppercase */
i = nestc[lvl];
if (i != '$') i = ((i == 2) ? 'd' : i - 32);
a[0] = '(';
a[1] = i;
a[2] = ')';
a[3] = EOL; /* command */
rcur = nestr[lvl] + rouptr; /* restore rcur */
j0 = (rouptr - 1);
j = 0;
tmp3[0] = EOL;
j0++;
if (rcur < rouend) {
while (j0 < (rcur - 1)) {
j1 = j0++;
j++;
if ((*j0 != TAB) && (*j0 != SP)) {
j = 0;
while ((tmp3[j] = (*(j0++))) > SP) {
if (tmp3[j] == '(') tmp3[j] = EOL;
j++;
}
tmp3[j] = EOL;
j = 0;
}
j0 = j1;
j0 += (UNSIGN (*j1)) + 2;
}
}
stcat (a, tmp3);
if (j > 0) {
i = stlen (a);
a[i++] = '+';
intstr (&a[i], j);
}
if (nestn[rlvl]) {
stcat (a, "^\201");
stcat (a, nestn[rlvl]);
}
else if (rou_name[0] != EOL) {
stcat (a, "^\201");
stcat (a, rou_name);
}
f = mcmnd;
mcmnd = 'd'; /* make load use standard-path */
zload (rou_name);
mcmnd = f;
return;
} /* end getraddress() */
/* parse lineref and return pos.in routine */
/* result: [pointer to] pointer to line */
void lineref (char **adrr)
{
long offset;
long j;
char *reg;
char *beg;
while (*codptr == '@') { /* handle indirection */
codptr++;
expr (ARGIND);
if (merr () > 0) return;
stcat (argptr, codptr);
stcpy (code, argptr);
codptr = code;
}
offset = 0;
beg = rouptr;
if (*codptr == '+') {
codptr++;
expr (STRING);
if (merr () > 0) return;
if ((offset = intexpr (argptr)) <= 0) {
*adrr = 0;
return;
}
offset--;
}
else {
expr (LABEL);
if (merr () > 0) return;
reg = beg;
while (beg < rouend) {
reg++;
if ((*reg) != TAB && (*reg) != SP) {
j = 0;
while ((*reg) == varnam[j]) {
reg++;
j++;
}
if (((*reg) == TAB || (*reg) == SP || (*reg) == '(') && varnam[j] == EOL) break;
}
reg = (beg = beg + UNSIGN (*beg) + 2);
}
stcpy (varerr, varnam);
varnam[0] = EOL;
codptr++;
if (*codptr == '+') {
codptr++;
expr (STRING);
if (merr () > 0) return;
offset = intexpr (argptr);
}
}
if (offset < 0) {
reg = rouptr;
while (reg < beg) {
reg += UNSIGN (*reg) + 2;
offset++;
}
if (offset < 0) {
*adrr = 0;
return;
}
beg = rouptr;
}
while (offset-- > 0 && beg <= rouend) beg += UNSIGN (*beg) + 2;
*adrr = beg;
return;
} /* end of lineref() */
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to routine.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / src