Adapted for new Pascal Compiler

lang/pc/libpc/LIST

@@ -68,4 +68,6 @@ wrz.c
 wrs.c
 outcpt.c
 wf.c
+nfa.c
+rcka.c
 trp.e

lang/pc/libpc/buff.c

@@ -31,5 +31,5 @@ buff(f) struct file *f; {
 		return;
 	_flush(f);
 	sz = f->size;
-	f->count = f->buflen = (sz>512 ? sz : 512-512%sz);
+	f->count = f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
 }

lang/pc/libpc/catch.c

@@ -18,15 +18,71 @@
 
 #include	<em_abs.h>
 #include	<em_path.h>
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 #define	MESLEN		30
 #define PATHLEN		100
 
 /* to make it easier to patch ... */
-char 			emdir[64] = EM_DIR;
 extern struct file	*_curfil;
 
+static struct errm {
+	int errno;
+	char *errmes;
+} errors[] = {
+	{ EARRAY,	"array bound error"},
+	{ ERANGE,	"range bound error"},
+	{ ESET,		"set bound error"},
+	{ EIOVFL,	"integer overflow"},
+	{ EFOVFL,	"real overflow"},
+	{ EFUNFL,	"real underflow"},
+	{ EIDIVZ,	"divide by 0"},
+	{ EFDIVZ,	"divide by 0.0"},
+	{ EIUND,	"undefined integer"},
+	{ EFUND,	"undefined real"},
+	{ ECONV,	"conversion error"},
+
+	{ ESTACK,	"stack overflow"},
+	{ EHEAP,	"heap overflow"},
+	{ EILLINS,	"illegal instruction"},
+	{ EODDZ,	"illegal size argument"},
+	{ ECASE,	"case error"},
+	{ EMEMFLT,	"addressing non existent memory"},
+	{ EBADPTR,	"bad pointer used"},
+	{ EBADPC,	"program counter out of range"},
+	{ EBADLAE,	"bad argument of lae"},
+	{ EBADMON,	"bad monitor call"},
+	{ EBADLIN,	"argument if LIN too high"},
+	{ EBADGTO,	"GTO descriptor error"},
+
+	{ EARGC,	"more args expected" },
+	{ EEXP,		"error in exp" },
+	{ ELOG,		"error in ln" },
+	{ ESQT,		"error in sqrt" },
+	{ EASS,		"assertion failed" },
+	{ EPACK,	"array bound error in pack" },
+	{ EUNPACK,	"array bound error in unpack" },
+	{ EMOD,		"only positive j in 'i mod j'" },
+	{ EBADF,	"file not yet open" },
+	{ EFREE,	"dispose error" },
+	{ EFUNASS,	"function not assigned" },
+	{ EWIDTH,	"illegal field width" },
+
+	{ EWRITEF,	"not writable" },
+	{ EREADF,	"not readable" },
+	{ EEOF,		"end of file" },
+	{ EFTRUNC,	"truncated" },
+	{ ERESET,	"reset error" },
+	{ EREWR,	"rewrite error" },
+	{ ECLOSE,	"close error" },
+	{ EREAD,	"read error" },
+	{ EWRITE,	"write error" },
+	{ EDIGIT,	"digit expected" },
+	{ EASCII,	"non-ASCII char read" },
+	{ -1,		0}
+};
+
 extern int		_pargc;
 extern char		**_pargv;
 extern char		**_penvp;
@@ -38,24 +94,22 @@ extern int		open();
 extern int		read();
 extern int		write();
 
-/* Modified not to use a table of indices any more. This circumvents yet 
-   another point where byte order in words would make you lose.
- */
-
 _catch(erno) unsigned erno; {
-	char		*p,*q,**qq;
-	unsigned	i;
-	int		fd;
-	char		*pp[8];
-	char		mes[MESLEN];
-	char		filename[PATHLEN];
-	char		c;
+	register struct errm *ep = &errors[0];
+	char *p,*q,*s,**qq;
+	char buf[20];
+	unsigned i;
+	int j = erno;
+	char *pp[10];
+	char mes[MESLEN];
 
 	qq = pp;
 	if (p = FILN)
 		*qq++ = p;
 	else
 		*qq++ = _pargv[0];
+
+	while (ep->errno != erno && ep->errmes != 0) ep++;
 	p = &("xxxxx: "[5]);
 	if (i = LINO) {
 		*qq++ = ", ";
@@ -70,25 +124,23 @@ _catch(erno) unsigned erno; {
 		*qq++ = _curfil->fname;
 		*qq++ = ": ";
 	}
-	if ( (i=strtobuf(emdir,filename,PATHLEN)) >= PATHLEN-1 ||
-	     (filename[i]='/' ,
-	      strtobuf(RTERR_PATH,filename+i+1,PATHLEN-i-1) >= PATHLEN-i-1
-	     ) )
-		goto error;
-	if ((fd=open(filename,0))<0)
-		goto error;
-	/* skip to correct message */
-	for(i=0;i<erno;i++)
-		do if (read(fd,&c,1)!=1)
-			goto error;
-		while (c!= '\n');
-	if(read(fd,mes,MESLEN-1)<=0)
-		goto error;
-	mes[MESLEN-1]=0;
-	for(i=0;i<MESLEN-1;i++)
-		if(mes[i]=='\n')
-			mes[i+1]=0;
-	*qq++ = mes;
+	if (ep->errmes) *qq++ = ep->errmes;
+	else {
+		q = "error number xxxxxxxxxxxxx";
+		p = &q[13];
+		s = buf;
+		if (j < 0) {
+			j = -j;
+			*p++ = '-';
+		}
+		do
+			*s++ = j % 10 + '0';
+		while (j /= 10);
+		while (s > buf) *p++ = *--s;
+		*p = 0;
+		*qq++ = q;
+	}
+	*qq++ = "\n";
 	*qq = 0;
 	qq = pp;
 	while (q = *qq++) {

lang/pc/libpc/hlt.c

@@ -20,16 +20,16 @@
 
 #include	<pc_file.h>
 
-extern char	*_hbase;
-extern int	*_extfl;
-extern		_cls();
-extern		exit();
+extern struct file	**_extfl;
+extern int		_extflc;
+extern			_cls();
+extern			exit();
 
 _hlt(ecode) int ecode; {
 	int i;
 
-	for (i = 1; i <= _extfl[0]; i++)
-		if (_extfl[i] != -1)
-			_cls(EXTFL(i));
+	for (i = 0; i < _extflc; i++)
+		if (_extfl[i] != (struct file *) 0)
+			_cls(_extfl[i]);
 	exit(ecode);
 }

lang/pc/libpc/ini.c

@@ -27,15 +27,15 @@ extern          _catch();
 extern int      gtty();
 #endif
 
-char            *_hbase;
-int             *_extfl;
+struct file     **_extfl;
+int		_extflc;	/* number of external files */
 char            *_m_lb;         /* LB of m_a_i_n */
 struct file     *_curfil;       /* points to file struct in case of errors */
 int             _pargc;
 char            **_pargv;
 char            **_penvp;
 
-_ini(args,hb,p,mainlb) char *args,*hb,*mainlb; int *p; {
+_ini(args,c,p,mainlb) char *args,*mainlb; int c; struct file **p; {
 	struct file *f;
 	char buf[128];
 
@@ -44,20 +44,19 @@ _ini(args,hb,p,mainlb) char *args,*hb,*mainlb; int *p; {
 	_penvp= *(char ***)args;
 	_sig(_catch);
 	_extfl = p;
-	_hbase = hb;
+	_extflc = c;
+	if( !c ) return;
 	_m_lb = mainlb;
-	if (_extfl[1] != -1) {
-		f = EXTFL(1);
+	if ( (f = _extfl[0]) != (struct file *) 0) {
 		f->ptr = f->bufadr;
 		f->flags = MAGIC|TXTBIT;
 		f->fname = "INPUT";
 		f->ufd = 0;
 		f->size = 1;
 		f->count = 0;
-		f->buflen = 512;
+		f->buflen = PC_BUFLEN;
 	}
-	if (_extfl[2] != -1) {
-		f = EXTFL(2);
+	if ( (f = _extfl[1]) != (struct file *) 0) {
 		f->ptr = f->bufadr;
 		f->flags = MAGIC|TXTBIT|WRBIT|EOFBIT|ELNBIT;
 		f->fname = "OUTPUT";
@@ -66,7 +65,7 @@ _ini(args,hb,p,mainlb) char *args,*hb,*mainlb; int *p; {
 #ifdef CPM
 		f->count = 1;
 #else
-		f->count = (gtty(1,buf) >= 0 ? 1 : 512);
+		f->count = (gtty(1,buf) >= 0 ? 1 : PC_BUFLEN);
 #endif
 		f->buflen = f->count;
 	}

lang/pc/libpc/mdi.c

@@ -24,6 +24,16 @@ extern		_trp();
 
 int _mdi(j,i) int j,i; {
 
+        if (j <= 0)
+                _trp(EMOD);
+        i = i % j;
+        if (i < 0)
+                i += j;
+        return(i);
+}
+
+long _mdil(j,i) long j,i; {
+
 	if (j <= 0)
 		_trp(EMOD);
 	i = i % j;

lang/pc/libpc/nfa.c

@@ -0,0 +1,10 @@
+/* Author: Hans van Eck */
+
+#include	<pc_err.h>
+
+extern trp();
+
+_nfa(bool)
+{
+	if (! bool) _trp(EFUNASS);
+}

lang/pc/libpc/opn.c

@@ -21,8 +21,8 @@
 #include	<pc_file.h>
 #include	<pc_err.h>
 
-extern char		*_hbase;
-extern int		*_extfl;
+extern struct file	**_extfl;
+extern int		_extflc;
 extern struct file	*_curfil;
 extern int		_pargc;
 extern char		**_pargv;
@@ -69,10 +69,10 @@ static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
 		sz++;
 		descr |= TXTBIT;
 	}
-	for (i=1; i<=_extfl[0]; i++)
-		if (f == EXTFL(i))
+	for (i=0; i<_extflc; i++)
+		if (f == _extfl[i])
 			break;
-	if (i > _extfl[0]) {		/* local file */
+	if (i >= _extflc) {		/* local file */
 		f->fname = "LOCAL";
 		if ((descr & WRBIT) == 0 && (f->flags & 0377) == MAGIC) {
 			_xcls(f);
@@ -83,7 +83,7 @@ static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
 			f->ufd = tmpfil();
 		}
 	} else {	/* external file */
-		if ((i -= 2) <= 0)
+		if (--i <= 0)
 			return(0);
 		if (i >= _pargc)
 			_trp(EARGC);
@@ -97,7 +97,7 @@ static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
 				_trp(EREWR);
 		}
 	}
-	f->buflen = (sz>512 ? sz : 512-512%sz);
+	f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
 	f->size = sz;
 	f->ptr = f->bufadr;
 	f->flags = descr;

lang/pc/libpc/pcreat.c

@@ -34,8 +34,8 @@ pcreat(f,s) struct file *f; char *s; {
 	f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
 	f->fname = s;
 	f->size = 1;
-	f->count = 512;
-	f->buflen = 512;
+	f->count = PC_BUFLEN;
+	f->buflen = PC_BUFLEN;
 	if ((f->ufd = creat(s,0644)) < 0)
 		_trp(EREWR);
 }

lang/pc/libpc/pentry.c

@@ -20,16 +20,16 @@
 
 #include	<pc_file.h>
 
-extern int	*_extfl;
-extern char	*_hbase;
-extern		_wrs();
-extern		_wln();
+extern struct file	**_extfl;
+extern			_wrs();
+extern			_wrz();
+extern			_wln();
 
 procentry(name) char *name; {
 	struct file *f;
 
-	f = EXTFL(2);
+	f = _extfl[1];
 	_wrs(5,"call ",f);
-	_wrs(8,name,f);
+	_wrz(name,f);
 	_wln(f);
 }

lang/pc/libpc/pexit.c

@@ -18,16 +18,16 @@
 
 #include	<pc_file.h>
 
-extern int	*_extfl;
-extern char	*_hbase;
-extern		_wrs();
-extern		_wln();
+extern struct file	**_extfl;
+extern			_wrs();
+extern			_wrz();
+extern			_wln();
 
 procexit(name) char *name; {
 	struct file *f;
 
-	f = EXTFL(2);
+	f = _extfl[1];
 	_wrs(5,"exit ",f);
-	_wrs(8,name,f);
+	_wrz(name,f);
 	_wln(f);
 }

lang/pc/libpc/popen.c

@@ -35,7 +35,7 @@ popen(f,s) struct file *f; char *s; {
 	f->fname = s;
 	f->size = 1;
 	f->count = 0;
-	f->buflen = 512;
+	f->buflen = PC_BUFLEN;
 	if ((f->ufd = open(s,0)) < 0)
 		_trp(ERESET);
 }

lang/pc/libpc/rcka.c

@@ -0,0 +1,19 @@
+/* Author: Hans van Eck */
+
+#include	<em_abs.h>
+
+extern trp();
+
+struct array_descr	{
+		int		lbound;
+		unsigned	n_elts_min_one;
+		unsigned	size;		/* doesn't really matter */
+	    };
+
+_rcka(descr, index)
+struct array_descr *descr;
+{
+	if( index < descr->lbound ||
+	    index > (int) descr->n_elts_min_one + descr->lbound )
+		_trp(ERANGE);
+}

lang/pc/libpc/wrf.c

@@ -18,6 +18,7 @@
 
 /* Author: J.W. Stevenson */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wstrin();
@@ -33,6 +34,7 @@ extern char	*_fcvt();
 _wrf(n,w,r,f) int n,w; double r; struct file *f; {
 	char *p,*b; int s,d; char buf[BUFSIZE];
 
+	if ( n < 0 || w < 0) _trp(EWIDTH);
 	p = buf;
 	if (n > PREC_DIG)
 		n = PREC_DIG;

lang/pc/libpc/wri.c

@@ -16,6 +16,7 @@
  *
  */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wstrin();
@@ -43,6 +44,7 @@ Something wrong here!
 _wsi(w,i,f) int w,i; struct file *f; {
 	char *p; int j; char buf[SZ];
 
+	if (w < 0) _trp(EWIDTH);
 	p = &buf[SZ];
 	if ((j=i) < 0) {
 		if (i == MININT) {

lang/pc/libpc/wrl.c

@@ -18,6 +18,7 @@
 
 /* Author: J.W. Stevenson */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wstrin();
@@ -27,6 +28,7 @@ extern		_wstrin();
 _wsl(w,l,f) int w; long l; struct file *f; {
 	char *p,c; long j; char buf[11];
 
+	if (w < 0) _trp(EWIDTH);
 	p = &buf[11];
 	if ((j=l) < 0) {
 		if (l == MAXNEGLONG) {

lang/pc/libpc/wrr.c

@@ -18,6 +18,7 @@
 
 /* Author: J.W. Stevenson */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wstrin();
@@ -26,8 +27,9 @@ extern char	*_ecvt();
 #define	PREC_DIG	80	/* maximum digits produced by _ecvt() */
 
 _wsr(w,r,f) int w; double r; struct file *f; {
-	char *p,*b; int s,d,i; char buf[PREC_DIG+6];
+	char *p,*b; int s,d,i; char buf[PREC_DIG+7];
 
+	if (w < 0) _trp(EWIDTH);
 	p = buf;
 	if ((i = w-6) < 2)
 		i = 2;
@@ -46,8 +48,17 @@ _wsr(w,r,f) int w; double r; struct file *f; {
 		*p++ = '-';
 	} else
 		*p++ = '+';
-	*p++ = '0' + (d/10);
-	*p++ = '0' + (d%10);
+
+	if (d >= 1000) {
+		*p++ = '*';
+		*p++ = '*';
+		*p++ = '*';
+	}
+	else {
+		*p++ = '0' + d/100;
+		*p++ = '0' + (d/10) % 10;
+		*p++ = '0' + d%10;
+	}
 	_wstrin(w,p-buf,buf,f);
 }
 

lang/pc/libpc/wrs.c

@@ -18,6 +18,7 @@
 
 /* Author: J.W. Stevenson */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wf();
@@ -37,16 +38,21 @@ _wstrin(width,len,buf,f) int width,len; char *buf; struct file *f; {
 }
 
 _wsc(w,c,f) int w; char c; struct file *f; {
+
+	if (w < 0) _trp(EWIDTH);
 	_wss(w,1,&c,f);
 }
 
 _wss(w,len,s,f) int w,len; char *s; struct file *f; {
+
+	if (w < 0 || len < 0) _trp(EWIDTH);
 	if (w < len)
 		len = w;
 	_wstrin(w,len,s,f);
 }
 
 _wrs(len,s,f) int len; char *s; struct file *f; {
+	if (len < 0) _trp(EWIDTH);
 	_wss(len,len,s,f);
 }
 

lang/pc/libpc/wrz.c

@@ -16,6 +16,7 @@
  *
  */
 
+#include	<pc_err.h>
 #include	<pc_file.h>
 
 extern		_wss();
@@ -24,6 +25,7 @@ extern		_wrs();
 _wsz(w,s,f) int w; char *s; struct file *f; {
 	char *p;
 
+	if (w < 0) _trp(EWIDTH);
 	for (p=s; *p; p++);
 	_wss(w,p-s,s,f);
 }