godzil/ack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixup commit for branch 'unlabeled-2.4.1'

Browse Source 
--HG--
branch : unlabeled-2.4.1
This commit is contained in:
cvs2hg
1984-10-16 13:31:45 +00:00
parent 5d5a09a5d0
commit c02387e38d
453 changed files with 0 additions and 81744 deletions
Download Patch File Download Diff File Expand all files Collapse all files

71
lang/pc/libpc/LIST
View File

@@ -1,71 +0,0 @@
tail_pc.a
abi.c
abl.c
abr.c
arg.c
ass.c
asz.c
atn.c
bcp.c
bts.e
buff.c
clock.c
diag.c
dis.c
efl.c
eln.c
encaps.e
exp.c
get.c
gto.e
hlt.c
ini.c
catch.c
log.c
mdi.c
mdl.c
new.c
nobuff.c
notext.c
opn.c
hol0.e
pac.c
pclose.c
pcreat.c
pentry.c
perrno.c
pexit.c
popen.c
cls.c
put.c
rdc.c
rdl.c
rdr.c
rdi.c
rln.c
rf.c
rnd.c
sav.e
sig.e
sin.c
sqt.c
fef.e
string.c
trap.e
unp.c
uread.c
uwrite.c
wdw.c
incpt.c
wrc.c
wrf.c
wri.c
wrl.c
wrr.c
cvt.c
fif.e
wrz.c
wrs.c
outcpt.c
wf.c
trp.e

16
lang/pc/libpc/Makefile
View File

@@ -1,16 +0,0 @@
# $Header$
head:
echo This Makefile needs arguments
distr:
rm `head -1 LIST`; arch cr `head -1 LIST` `tail +2 LIST`
clean:
rm -f *.old
opr:
make pr | opr
pr:
@pr Makefile *.[ec]

11
lang/pc/libpc/READ_ME
View File

@@ -1,11 +0,0 @@
problems:
- names of system call routines may clash with user routines
- some modules in Pascal?
- ttyio, stdio, pasio, unixio
- mention all external references
- list of routines and partitioning
- size of sizes in asz,bcp,dis,new,opn,pac,unp: int or long ?
NOTE:
The run files in mach/*/libpc show the actual usage of this
library.

23
lang/pc/libpc/abi.c
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
int _abi(i) int i; {
return(i>=0 ? i : -i);
}

23
lang/pc/libpc/abl.c
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
long _abl(i) long i; {
return(i>=0 ? i : -i);
}

23
lang/pc/libpc/abr.c
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
double _abr(r) double r; {
return(r>=0 ? r : -r);
}

56
lang/pc/libpc/arg.c
View File

@@ -1,56 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
/*
/* function argc:integer; extern; */
/* function argv(i:integer):string; extern; */
/* procedure argshift; extern; */
/* function environ(i:integer):string; extern; */
extern int _pargc;
extern char **_pargv;
extern char **_penvp;
int argc() {
return(_pargc);
}
char *argv(i) {
if (i >= _pargc)
return(0);
return(_pargv[i]);
}
argshift() {
if (_pargc > 1) {
--_pargc;
_pargv++;
}
}
char *environ(i) {
char **p; char *q;
if (p = _penvp)
while (q = *p++)
if (i-- < 0)
return(q);
return(0);
}

33
lang/pc/libpc/ass.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <em_abs.h>
#include <pc_err.h>
extern char *_hol0();
extern _trp();
_ass(line,bool) int line,bool; {
if (bool==0) {
LINO = line;
_trp(EASS);
}
}

29
lang/pc/libpc/asz.c
View File

@@ -1,29 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
struct descr {
int low;
int diff;
int size;
};
int _asz(dp) struct descr *dp; {
return(dp->size * (dp->diff + 1));
}

74
lang/pc/libpc/atn.c
View File

@@ -1,74 +0,0 @@
/* $Header$ */
/*
floating-point arctangent
atan returns the value of the arctangent of its
argument in the range [-pi/2,pi/2].
there are no error returns.
coefficients are #5077 from Hart & Cheney. (19.56D)
*/
static double sq2p1 = 2.414213562373095048802e0;
static double sq2m1 = .414213562373095048802e0;
static double pio2 = 1.570796326794896619231e0;
static double pio4 = .785398163397448309615e0;
static double p4 = .161536412982230228262e2;
static double p3 = .26842548195503973794141e3;
static double p2 = .11530293515404850115428136e4;
static double p1 = .178040631643319697105464587e4;
static double p0 = .89678597403663861959987488e3;
static double q4 = .5895697050844462222791e2;
static double q3 = .536265374031215315104235e3;
static double q2 = .16667838148816337184521798e4;
static double q1 = .207933497444540981287275926e4;
static double q0 = .89678597403663861962481162e3;
/*
xatan evaluates a series valid in the
range [-0.414...,+0.414...].
*/
static double
xatan(arg)
double arg;
{
double argsq;
double value;
argsq = arg*arg;
value = ((((p4*argsq + p3)*argsq + p2)*argsq + p1)*argsq + p0);
value = value/(((((argsq + q4)*argsq + q3)*argsq + q2)*argsq + q1)*argsq + q0);
return(value*arg);
}
static double
satan(arg)
double arg;
{
if(arg < sq2m1)
return(xatan(arg));
else if(arg > sq2p1)
return(pio2 - xatan(1/arg));
else
return(pio4 + xatan((arg-1)/(arg+1)));
}
/*
atan makes its argument positive and
calls the inner routine satan.
*/
double
_atn(arg)
double arg;
{
if(arg>0)
return(satan(arg));
else
return(-satan(-arg));
}

30
lang/pc/libpc/bcp.c
View File

@@ -1,30 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
int _bcp(sz,y,x) int sz; char *y,*x; {
while (--sz >= 0) {
if (*x < *y)
return(-1);
if (*x++ > *y++)
return(1);
}
return(0);
}

56
lang/pc/libpc/bts.e
View File

@@ -1,56 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
; Author: J.W. Stevenson */
mes 2,EM_WSIZE,EM_PSIZE
#define SIZE 0
#define HIGH EM_WSIZE
#define LOWB 2*EM_WSIZE
#define BASE 3*EM_WSIZE
; _bts is called with four parameters:
; - the initial set (BASE)
; - low bound of range of bits (LOWB)
; - high bound of range of bits (HIGH)
; - set size in bytes (SIZE)
exp $_bts
pro $_bts,0
lal BASE ; address of initial set
lol SIZE
los EM_WSIZE ; load initial set
1
lol LOWB ; low bound
lol HIGH ; high bound
bgt *2 ; while low <= high
lol LOWB
lol SIZE
set ? ; create [low]
lol SIZE
ior ? ; merge with initial set
inl LOWB ; increment low bound
bra *1 ; loop back
2
lal BASE
lol SIZE
sts EM_WSIZE ; store result over initial set
ret 0
end ?

35
lang/pc/libpc/buff.c
View File

@@ -1,35 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _flush();
/* procedure buff(var f:file of ?); */
buff(f) struct file *f; {
int sz;
if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
return;
_flush(f);
sz = f->size;
f->count = f->buflen = (sz>512 ? sz : 512-512%sz);
}

102
lang/pc/libpc/catch.c
View File

@@ -1,102 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <em_abs.h>
#include <em_path.h>
#include <pc_file.h>
#define MESLEN 30
#define PATHLEN 100
extern struct file *_curfil;
extern int _pargc;
extern char **_pargv;
extern char **_penvp;
extern char *_hol0();
extern _trp();
extern exit();
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;
qq = pp;
if (p = FILN)
*qq++ = p;
else
*qq++ = _pargv[0];
p = &("xxxxx: "[5]);
if (i = LINO) {
*qq++ = ", ";
do
*--p = i % 10 + '0';
while (i /= 10);
}
*qq++ = p;
if ((erno & ~037) == 0140 && (_curfil->flags&0377)==MAGIC) {
/* file error */
*qq++ = "file ";
*qq++ = _curfil->fname;
*qq++ = ": ";
}
if ( (i=strtobuf(EM_DIR,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;
*qq = 0;
qq = pp;
while (q = *qq++) {
p = q;
while (*p)
p++;
if (write(2,q,p-q) < 0)
;
}
exit(erno);
error:
_trp(erno);
}

37
lang/pc/libpc/clock.c
View File

@@ -1,37 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
/* function clock:integer; extern; */
extern int times();
struct tbuf {
long utime;
long stime;
long cutime;
long cstime;
};
int clock() {
struct tbuf t;
times(&t);
return( (t.utime + t.stime) & 077777);
}

67
lang/pc/libpc/cls.c
View File

@@ -1,67 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern struct file *_curfil;
extern _trp();
extern _flush();
extern _outcpt();
extern int close();
_xcls(f) struct file *f; {
if ((f->flags & WRBIT) == 0)
return;
if ((f->flags & (TXTBIT|ELNBIT)) == TXTBIT) {
#ifdef CPM
*f->ptr = '\r';
_outcpt(f);
#endif
*f->ptr = '\n';
_outcpt(f);
}
_flush(f);
}
_cls(f) struct file *f; {
#ifdef MAYBE
char *p;
#endif
_curfil = f;
if ((f->flags&0377) != MAGIC)
return;
#ifdef MAYBE
p = f->bufadr;
if (f->ptr < p)
return;
if (f->buflen <= 0)
return;
p += f->buflen;
if (f->ptr >= p)
return;
#endif
_xcls(f);
if (close(f->ufd) != 0)
_trp(ECLOSE);
f->flags = 0;
}

122
lang/pc/libpc/cvt.c
View File

@@ -1,122 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
extern double _fif();
/*
* _ecvt converts to decimal
* the number of digits is specified by ndigit
* decpt is set to the position of the decimal point
* sign is set to 0 for positive, 1 for negative
*/
#define NDIG 80
static char*
cvt(arg, ndigits, decpt, sign, eflag)
double arg;
int ndigits, *decpt, *sign, eflag;
{
register int r2;
double fi, fj;
register char *p, *p1;
static char buf[NDIG];
int i; /*!*/
if (ndigits<0)
ndigits = 0;
if (ndigits>=NDIG-1)
ndigits = NDIG-2;
r2 = 0;
*sign = 0;
p = &buf[0];
if (arg<0) {
*sign = 1;
arg = -arg;
}
arg = _fif(arg, 1.0, &fi);
/*
* Do integer part
*/
if (fi != 0) {
p1 = &buf[NDIG];
while (fi != 0) {
i = (_fif(fi, 0.1, &fi) + 0.03) * 10;
*--p1 = i + '0';
r2++;
}
while (p1 < &buf[NDIG])
*p++ = *p1++;
} else if (arg > 0) {
while ((fj = arg*10) < 1) {
arg = fj;
r2--;
}
}
p1 = &buf[ndigits];
if (eflag==0)
p1 += r2;
*decpt = r2;
if (p1 < &buf[0]) {
buf[0] = '\0';
return(buf);
}
while (p<=p1 && p<&buf[NDIG]) {
arg = _fif(arg, 10.0, &fj);
i = fj;
*p++ = i + '0';
}
if (p1 >= &buf[NDIG]) {
buf[NDIG-1] = '\0';
return(buf);
}
p = p1;
*p1 += 5;
while (*p1 > '9') {
*p1 = '0';
if (p1>buf) {
p1--; *p1 += 1;
} else {
*p1 = '1';
(*decpt)++;
if (eflag==0) {
if (p>buf)
*p = '0';
p++;
}
}
}
*p = '\0';
return(buf);
}
char*
_ecvt(arg, ndigits, decpt, sign)
double arg;
int ndigits, *decpt, *sign;
{
return(cvt(arg, ndigits, decpt, sign, 1));
}
char*
_fcvt(arg, ndigits, decpt, sign)
double arg;
int ndigits, *decpt, *sign;
{
return(cvt(arg, ndigits, decpt, sign, 0));
}

34
lang/pc/libpc/diag.c
View File

@@ -1,34 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
/* procedure diag(var f:text); */
diag(f) struct file *f; {
f->ptr = f->bufadr;
f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
f->fname = "DIAG";
f->ufd = 2;
f->size = 1;
f->count = 1;
f->buflen = 1;
}

87
lang/pc/libpc/dis.c
View File

@@ -1,87 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_err.h>
#define assert() /* nothing */
/*
* use circular list of free blocks from low to high addresses
* _highp points to free block with highest address
*/
struct adm {
struct adm *next;
int size;
};
extern struct adm *_lastp;
extern struct adm *_highp;
extern _trp();
static int merge(p1,p2) struct adm *p1,*p2; {
struct adm *p;
p = (struct adm *)((char *)p1 + p1->size);
if (p > p2)
_trp(EFREE);
if (p != p2)
return(0);
p1->size += p2->size;
p1->next = p2->next;
return(1);
}
_dis(n,pp) int n; struct adm **pp; {
struct adm *p1,*p2;
/*
* NOTE: dispose only objects whose size is a multiple of sizeof(*pp).
* this is always true for objects allocated by _new()
*/
n = ((n+sizeof(*p1)-1) / sizeof(*p1)) * sizeof(*p1);
if (n == 0)
return;
if ((p1= *pp) == (struct adm *) 0)
_trp(EFREE);
p1->size = n;
if ((p2 = _highp) == 0) /*p1 is the only free block*/
p1->next = p1;
else {
if (p2 > p1) {
/*search for the preceding free block*/
if (_lastp < p1) /*reduce search*/
p2 = _lastp;
while (p2->next < p1)
p2 = p2->next;
}
/* if p2 preceeds p1 in the circular list,
* try to merge them */
p1->next = p2->next; p2->next = p1;
if (p2 <= p1 && merge(p2,p1))
p1 = p2;
p2 = p1->next;
/* p1 preceeds p2 in the circular list */
if (p2 > p1) merge(p1,p2);
}
if (p1 >= p1->next)
_highp = p1;
_lastp = p1;
*pp = (struct adm *) 0;
}

36
lang/pc/libpc/efl.c
View File

@@ -1,36 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern struct file *_curfil;
extern _trp();
extern _incpt();
int _efl(f) struct file *f; {
_curfil = f;
if ((f->flags & 0377) != MAGIC)
_trp(EBADF);
if ((f->flags & (WINDOW|WRBIT|EOFBIT)) == 0)
_incpt(f);
return((f->flags & EOFBIT) != 0);
}

33
lang/pc/libpc/eln.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern _trp();
extern _rf();
int _eln(f) struct file *f; {
_rf(f);
if (f->flags & EOFBIT)
_trp(EEOF);
return((f->flags & ELNBIT) != 0);
}

144
lang/pc/libpc/encaps.e
View File

@@ -1,144 +0,0 @@
#
; $Header$
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
mes 2,EM_WSIZE,EM_PSIZE
; procedure encaps(procedure p; procedure(q(n:integer));
; {call q if a trap occurs during the execution of p}
; {if q returns, continue execution of p}
inp $handler
#define PIISZ 2*EM_PSIZE
#define PARG 0
#define QARG PIISZ
#define E_ELB -EM_PSIZE
#define E_EHA -2*EM_PSIZE
; encaps is called with two parameters:
; - procedure instance identifier of q (QARG)
; - procedure instance identifier of p (PARG)
; and two local variables:
; - the lb of the previous encaps (E_ELB)
; - the procedure identifier of the previous handler (E_EHA)
;
; One static variable:
; - the lb of the currently active encaps (enc_lb)
enc_lb
bss EM_PSIZE,0,0
exp $encaps
pro $encaps,PIISZ
; save lb of previous encaps
lae enc_lb
loi EM_PSIZE
lal E_ELB
sti EM_PSIZE
; set new lb
lxl 0
lae enc_lb
sti EM_PSIZE
; save old handler id while setting up the new handler
lpi $handler
sig
lal E_EHA
sti EM_PSIZE
; handler is ready, p can be called
; p doesn't expect parameters except possibly the static link
; always passing the link won't hurt
lal PARG
loi PIISZ
cai
asp EM_PSIZE
; reinstate old handler
lal E_ELB
loi EM_PSIZE
lae enc_lb
sti EM_PSIZE
lal E_EHA
loi EM_PSIZE
sig
asp EM_PSIZE
ret 0
end ?
#define TRAP 0
#define H_ELB -EM_PSIZE
; handler is called with one parameter:
; - trap number (TRAP)
; one local variable
; - the current LB of the enclosing encaps (H_ELB)
pro $handler,EM_PSIZE
; save LB of nearest encaps
lae enc_lb
loi EM_PSIZE
lal H_ELB
sti EM_PSIZE
; fetch setting for previous encaps via LB of nearest
lal H_ELB
loi EM_PSIZE
adp E_ELB
loi EM_PSIZE ; LB of previous encaps
lae enc_lb
sti EM_PSIZE
lal H_ELB
loi EM_PSIZE
adp E_EHA
loi EM_PSIZE ; previous handler
sig
asp EM_PSIZE
; previous handler is re-instated, time to call Q
lol TRAP ; the one and only real parameter
lal H_ELB
loi EM_PSIZE
lpb ; argument base of enclosing encaps
adp QARG
loi PIISZ
exg EM_PSIZE
dup EM_PSIZE ; The static link is now on top
zer EM_PSIZE
cmp
zeq *1
; non-zero LB
exg EM_PSIZE
cai
asp EM_WSIZE+EM_PSIZE
bra *2
1
; zero LB
asp EM_PSIZE
cai
asp EM_WSIZE
2
; now reinstate handler for continued execution of p
lal H_ELB
loi EM_PSIZE
lae enc_lb
sti EM_PSIZE
lpi $handler
sig
asp EM_PSIZE
rtt
end ?

106
lang/pc/libpc/exp.c
View File

@@ -1,106 +0,0 @@
/* $Header$ */
#include <pc_err.h>
extern double _fif();
extern double _fef();
extern _trp();
/*
exp returns the exponential function of its
floating-point argument.
The coefficients are #1069 from Hart and Cheney. (22.35D)
*/
#define HUGE 1.701411733192644270e38
static double p0 = .2080384346694663001443843411e7;
static double p1 = .3028697169744036299076048876e5;
static double p2 = .6061485330061080841615584556e2;
static double q0 = .6002720360238832528230907598e7;
static double q1 = .3277251518082914423057964422e6;
static double q2 = .1749287689093076403844945335e4;
static double log2e = 1.4426950408889634073599247;
static double sqrt2 = 1.4142135623730950488016887;
static double maxf = 10000.0;
static double
floor(d)
double d;
{
if (d<0) {
d = -d;
if (_fif(d, 1.0, &d) != 0)
d += 1;
d = -d;
} else
_fif(d, 1.0, &d);
return(d);
}
static double
ldexp(fr,exp)
double fr;
int exp;
{
int neg,i;
neg = 1;
if (fr < 0) {
fr = -fr;
neg = -1;
}
fr = _fef(fr, &i);
/*
while (fr < 0.5) {
fr *= 2;
exp--;
}
*/
exp += i;
if (exp > 127) {
_trp(EEXP);
return(neg * HUGE);
}
if (exp < -127)
return(0);
while (exp > 14) {
fr *= (1<<14);
exp -= 14;
}
while (exp < -14) {
fr /= (1<<14);
exp += 14;
}
if (exp > 0)
fr *= (1<<exp);
if (exp < 0)
fr /= (1<<(-exp));
return(neg * fr);
}
double
_exp(arg)
double arg;
{
double fract;
double temp1, temp2, xsq;
int ent;
if(arg == 0)
return(1);
if(arg < -maxf)
return(0);
if(arg > maxf) {
_trp(EEXP);
return(HUGE);
}
arg *= log2e;
ent = floor(arg);
fract = (arg-ent) - 0.5;
xsq = fract*fract;
temp1 = ((p2*xsq+p1)*xsq+p0)*fract;
temp2 = ((xsq+q2)*xsq+q1)*xsq + q0;
return(ldexp(sqrt2*(temp2+temp1)/(temp2-temp1), ent));
}

39
lang/pc/libpc/fef.e
View File

@@ -1,39 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
#define FARG 0
#define ERES EM_DSIZE
; _fef is called with two parameters:
; - address of exponent result (ERES)
; - floating point number to be split (FARG)
; and returns an EM_DSIZE-byte floating point number
exp $_fef
pro $_fef,0
lal FARG
loi EM_DSIZE
fef EM_DSIZE
lal ERES
loi EM_PSIZE
sti EM_WSIZE
ret EM_DSIZE
end ?

41
lang/pc/libpc/fif.e
View File

@@ -1,41 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
#define ARG1 0
#define ARG2 EM_DSIZE
#define IRES 2*EM_DSIZE
; _fif is called with three parameters:
; - address of integer part result (IRES)
; - float two (ARG2)
; - float one (ARG1)
; and returns an EM_DSIZE-byte floating point number
exp $_fif
pro $_fif,0
lal 0
loi 2*EM_DSIZE
fif EM_DSIZE
lal IRES
loi EM_PSIZE
sti EM_DSIZE
ret EM_DSIZE
end ?

31
lang/pc/libpc/get.c
View File

@@ -1,31 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
#include <pc_err.h>
extern _rf();
extern _trp();
_get(f) struct file *f; {
_rf(f);
if (f->flags&EOFBIT)
_trp(EEOF);
f->flags &= ~WINDOW;
}

85
lang/pc/libpc/gto.e
View File

@@ -1,85 +0,0 @@
#
; $Header$
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
/* Author: J.W. Stevenson */
mes 2,EM_WSIZE,EM_PSIZE
#define TARLB 0
#define DESCR EM_PSIZE
#define NEWPC 0
#define SAVSP EM_PSIZE
#define D_PC 0
#define D_SP EM_PSIZE
#define D_LB EM_PSIZE+EM_PSIZE
#define LOCLB -EM_PSIZE
; _gto is called with two arguments:
; - pointer to the label descriptor (DESCR)
; - local base (LB) of target procedure (TARLB)
; the label descriptor contains two items:
; - label address i.e. new PC (NEWPC)
; - offset in target procedure frame (SAVSP)
; using this offset and the LB of the target procedure, the address of
; of local variable of the target procedure is constructed.
; the target procedure must have stored the correct target SP there.
descr
bss 3*EM_PSIZE,0,0
exp $_gto
pro $_gto,EM_PSIZE
lal DESCR
loi EM_PSIZE
adp NEWPC
loi EM_PSIZE
lae descr+D_PC
sti EM_PSIZE
lal TARLB
loi EM_PSIZE
zer EM_PSIZE
cmp
zeq *1
lal TARLB
loi EM_PSIZE
bra *2
1
lae _m_lb
loi EM_PSIZE
2
lal LOCLB
sti EM_PSIZE
lal LOCLB
loi EM_PSIZE
lal DESCR
loi EM_PSIZE
adp SAVSP
loi EM_WSIZE ; or EM_PSIZE ?
ads EM_WSIZE ; or EM_PSIZE ?
loi EM_PSIZE
lae descr+D_SP
sti EM_PSIZE
lal LOCLB
loi EM_PSIZE
lae descr+D_LB
sti EM_PSIZE
gto descr
end ?

3
lang/pc/libpc/head_pc.e
View File

@@ -1,3 +0,0 @@
#
; $Header$
mes 2,EM_WSIZE,EM_PSIZE

35
lang/pc/libpc/hlt.c
View File

@@ -1,35 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern char *_hbase;
extern int *_extfl;
extern _cls();
extern exit();
_hlt(ecode) int ecode; {
int i;
for (i = 1; i <= _extfl[0]; i++)
if (_extfl[i] != -1)
_cls(EXTFL(i));
exit(ecode);
}

29
lang/pc/libpc/hol0.e
View File

@@ -1,29 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
; _hol0 return the address of the ABS block (hol0)
exp $_hol0
pro $_hol0,0
lae 0
ret EM_PSIZE
end ?

75
lang/pc/libpc/incpt.c
View File

@@ -1,75 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
#define EINTR 4
extern int errno;
extern _trp();
extern int read();
_incpt(f) struct file *f; {
if (f->flags & EOFBIT)
_trp(EEOF);
f->flags |= WINDOW;
f->flags &= ~ELNBIT;
#ifdef CPM
do {
#endif
f->ptr += f->size;
if (f->count == 0) {
f->ptr = f->bufadr;
for(;;) {
f->count=read(f->ufd,f->bufadr,f->buflen);
if ( f->count<0 ) {
if (errno != EINTR) _trp(EREAD) ;
continue ;
}
break ;
}
if (f->count == 0) {
f->flags |= EOFBIT;
*f->ptr = '\0';
return;
}
}
if ((f->count -= f->size) < 0)
_trp(EFTRUNC);
#ifdef CPM
} while ((f->flags&TXTBIT) && *f->ptr == '\r');
#endif
if (f->flags & TXTBIT) {
if (*f->ptr & 0200)
_trp(EASCII);
if (*f->ptr == '\n') {
f->flags |= ELNBIT;
*f->ptr = ' ';
}
#ifdef CPM
if (*f->ptr == 26) {
f->flags |= EOFBIT;
*f->ptr = 0;
}
#endif
}
}

73
lang/pc/libpc/ini.c
View File

@@ -1,73 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern (*_sig())();
extern _catch();
#ifndef CPM
extern int ioctl();
#endif
char *_hbase;
int *_extfl;
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; {
struct file *f;
char buf[6];
_pargc= *(int *)args; args += sizeof (int);
_pargv= *(char ***)args; args += sizeof (char **);
_penvp= *(char ***)args;
_sig(_catch);
_extfl = p;
_hbase = hb;
_m_lb = mainlb;
if (_extfl[1] != -1) {
f = EXTFL(1);
f->ptr = f->bufadr;
f->flags = MAGIC|TXTBIT;
f->fname = "INPUT";
f->ufd = 0;
f->size = 1;
f->count = 0;
f->buflen = 512;
}
if (_extfl[2] != -1) {
f = EXTFL(2);
f->ptr = f->bufadr;
f->flags = MAGIC|TXTBIT|WRBIT|EOFBIT|ELNBIT;
f->fname = "OUTPUT";
f->ufd = 1;
f->size = 1;
#ifdef CPM
f->count = 1;
#else
f->count = (ioctl(1,(('t'<<8)|8),buf) == 0 ? 1 : 512);
#endif
f->buflen = f->count;
}
}

59
lang/pc/libpc/log.c
View File

@@ -1,59 +0,0 @@
/* $Header$ */
#include <pc_err.h>
extern double _fef();
extern _trp();
/*
log returns the natural logarithm of its floating
point argument.
The coefficients are #2705 from Hart & Cheney. (19.38D)
It calls _fef.
*/
#define HUGE 1.701411733192644270e38
static double log2 = 0.693147180559945309e0;
static double sqrto2 = 0.707106781186547524e0;
static double p0 = -.240139179559210510e2;
static double p1 = 0.309572928215376501e2;
static double p2 = -.963769093368686593e1;
static double p3 = 0.421087371217979714e0;
static double q0 = -.120069589779605255e2;
static double q1 = 0.194809660700889731e2;
static double q2 = -.891110902798312337e1;
double
_log(arg)
double arg;
{
double x,z, zsq, temp;
int exp;
if(arg <= 0) {
_trp(ELOG);
return(-HUGE);
}
x = _fef(arg,&exp);
/*
while(x < 0.5) {
x =* 2;
exp--;
}
*/
if(x<sqrto2) {
x *= 2;
exp--;
}
z = (x-1)/(x+1);
zsq = z*z;
temp = ((p3*zsq + p2)*zsq + p1)*zsq + p0;
temp = temp/(((zsq + q2)*zsq + q1)*zsq + q0);
temp = temp*z + exp*log2;
return(temp);
}

33
lang/pc/libpc/mdi.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_err.h>
extern _trp();
int _mdi(j,i) int j,i; {
if (j <= 0)
_trp(EMOD);
i = i % j;
if (i < 0)
i += j;
return(i);
}

33
lang/pc/libpc/mdl.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_err.h>
extern _trp();
long _mdl(j,i) long j,i; {
if (j <= 0)
_trp(EMOD);
i = i % j;
if (i < 0)
i += j;
return(i);
}

67
lang/pc/libpc/new.c
View File

@@ -1,67 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
extern _sav();
extern _rst();
#define assert() /* nothing */
#define UNDEF 0x8000
struct adm {
struct adm *next;
int size;
};
struct adm *_lastp = 0;
struct adm *_highp = 0;
_new(n,pp) int n; struct adm **pp; {
struct adm *p,*q;
n = ((n+sizeof(*p)-1) / sizeof(*p)) * sizeof(*p);
if ((p = _lastp) != 0)
do {
q = p->next;
if (q->size >= n) {
assert(q->size%sizeof(adm) == 0);
if ((q->size -= n) == 0) {
if (p == q)
p = 0;
else
p->next = q->next;
if (q == _highp)
_highp = p;
}
_lastp = p;
p = (struct adm *)((char *)q + q->size);
q = (struct adm *)((char *)p + n);
goto initialize;
}
p = q;
} while (p != _lastp);
/*no free block big enough*/
_sav(&p);
q = (struct adm *)((char *)p + n);
_rst(&q);
initialize:
*pp = p;
while (p < q)
*((int *)p)++ = UNDEF;
}

33
lang/pc/libpc/nobuff.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _flush();
/* procedure nobuff(var f:file of ?); */
nobuff(f) struct file *f; {
if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
return;
_flush(f);
f->count = f->buflen = f->size;
}

23
lang/pc/libpc/notext.c
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
notext(f) struct file *f; {
f->flags &= ~TXTBIT;
}

117
lang/pc/libpc/opn.c
View File

@@ -1,117 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern char *_hbase;
extern int *_extfl;
extern struct file *_curfil;
extern int _pargc;
extern char **_pargv;
extern char **_penvp;
extern _cls();
extern _xcls();
extern _trp();
extern int getpid();
extern int creat();
extern int open();
extern int close();
extern int unlink();
extern long lseek();
static int tmpfil() {
int i; char *p,*q;
i = getpid();
p = "/usr/tmp/plf.xxxxx";
q = p + 13;
do
*q++ = (i & 07) + '0';
while (i >>= 3);
*q = '\0';
if ((i = creat(p,0644)) < 0)
if ((i = creat(p += 4,0644)) < 0)
if ((i = creat(p += 5,0644)) < 0)
goto error;
if (close(i) != 0)
goto error;
if ((i = open(p,2)) < 0)
goto error;
if (unlink(p) != 0)
error: _trp(EREWR);
return(i);
}
static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
int i;
_curfil = f;
if (sz == 0) {
sz++;
descr |= TXTBIT;
}
for (i=1; i<=_extfl[0]; i++)
if (f == EXTFL(i))
break;
if (i > _extfl[0]) { /* local file */
f->fname = "LOCAL";
if ((descr & WRBIT) == 0 && (f->flags & 0377) == MAGIC) {
_xcls(f);
if (lseek(f->ufd,(long)0,0) == -1)
_trp(ERESET);
} else {
_cls(f);
f->ufd = tmpfil();
}
} else { /* external file */
if ((i -= 2) <= 0)
return(0);
if (i >= _pargc)
_trp(EARGC);
f->fname = _pargv[i];
_cls(f);
if ((descr & WRBIT) == 0) {
if ((f->ufd = open(f->fname,0)) < 0)
_trp(ERESET);
} else {
if ((f->ufd = creat(f->fname,0644)) < 0)
_trp(EREWR);
}
}
f->buflen = (sz>512 ? sz : 512-512%sz);
f->size = sz;
f->ptr = f->bufadr;
f->flags = descr;
return(1);
}
_opn(sz,f) int sz; struct file *f; {
if (initfl(MAGIC,sz,f))
f->count = 0;
}
_cre(sz,f) int sz; struct file *f; {
if (initfl(WRBIT|EOFBIT|ELNBIT|MAGIC,sz,f))
f->count = f->buflen;
}

50
lang/pc/libpc/outcpt.c
View File

@@ -1,50 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
#define EINTR 4
extern int errno;
extern _trp();
extern int write();
_flush(f) struct file *f; {
int i,n;
f->ptr = f->bufadr;
n = f->buflen - f->count;
if (n <= 0)
return;
f->count = f->buflen;
if ((i = write(f->ufd,f->bufadr,n)) < 0 && errno == EINTR)
return;
if (i != n)
_trp(EWRITE);
}
_outcpt(f) struct file *f; {
f->flags &= ~ELNBIT;
f->ptr += f->size;
if ((f->count -= f->size) <= 0)
_flush(f);
}

50
lang/pc/libpc/pac.c
View File

@@ -1,50 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_err.h>
extern _trp();
#define assert() /* nothing */
struct descr {
int low;
int diff;
int size;
};
_pac(ad,zd,zp,i,ap) int i; struct descr *ad,*zd; char *zp,*ap; {
if (zd->diff > ad->diff ||
(i -= ad->low) < 0 ||
(i+zd->diff) > ad->diff)
_trp(EPACK);
ap += (i * ad->size);
i = (zd->diff + 1) * zd->size;
if (zd->size == 1) {
assert(ad->size == 2);
while (--i >= 0)
*zp++ = *((int *)ap)++;
} else {
assert(ad->size == zd->size);
while (--i >= 0)
*zp++ = *ap++;
}
}

27
lang/pc/libpc/pclose.c
View File

@@ -1,27 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _cls();
/* procedure pclose(var f:file of ??); */
pclose(f) struct file *f; {
_cls(f);
}

41
lang/pc/libpc/pcreat.c
View File

@@ -1,41 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern _cls();
extern _trp();
extern int creat();
/* procedure pcreat(var f:text; s:string); */
pcreat(f,s) struct file *f; char *s; {
_cls(f); /* initializes _curfil */
f->ptr = f->bufadr;
f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
f->fname = s;
f->size = 1;
f->count = 512;
f->buflen = 512;
if ((f->ufd = creat(s,0644)) < 0)
_trp(EREWR);
}

35
lang/pc/libpc/pentry.c
View File

@@ -1,35 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern int *_extfl;
extern char *_hbase;
extern _wrs();
extern _wln();
procentry(name) char *name; {
struct file *f;
f = EXTFL(2);
_wrs(5,"call ",f);
_wrs(8,name,f);
_wln(f);
}

25
lang/pc/libpc/perrno.c
View File

@@ -1,25 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* function perrno:integer; extern; */
extern int errno;
int perrno() {
return(errno);
}

33
lang/pc/libpc/pexit.c
View File

@@ -1,33 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern int *_extfl;
extern char *_hbase;
extern _wrs();
extern _wln();
procexit(name) char *name; {
struct file *f;
f = EXTFL(2);
_wrs(5,"exit ",f);
_wrs(8,name,f);
_wln(f);
}

41
lang/pc/libpc/popen.c
View File

@@ -1,41 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern _cls();
extern _trp();
extern int open();
/* procedure popen(var f:text; s:string); */
popen(f,s) struct file *f; char *s; {
_cls(f); /* initializes _curfil */
f->ptr = f->bufadr;
f->flags = TXTBIT|MAGIC;
f->fname = s;
f->size = 1;
f->count = 0;
f->buflen = 512;
if ((f->ufd = open(s,0)) < 0)
_trp(ERESET);
}

27
lang/pc/libpc/put.c
View File

@@ -1,27 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _wf();
extern _outcpt();
_put(f) struct file *f; {
_wf(f);
_outcpt(f);
}

31
lang/pc/libpc/rdc.c
View File

@@ -1,31 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _rf();
extern _incpt();
int _rdc(f) struct file *f; {
int c;
_rf(f);
c = *f->ptr;
_incpt(f);
return(c);
}

78
lang/pc/libpc/rdi.c
View File

@@ -1,78 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#include <pc_err.h>
extern _trp();
extern _rf();
extern _incpt();
_skipsp(f) struct file *f; {
while ((*f->ptr == ' ') || (*f->ptr == '\t'))
_incpt(f);
}
int _getsig(f) struct file *f; {
int sign;
if ((sign = (*f->ptr == '-')) || *f->ptr == '+')
_incpt(f);
return(sign);
}
int _fstdig(f) struct file *f; {
int ch;
ch = *f->ptr - '0';
if ((unsigned) ch > 9) {
_trp(EDIGIT);
ch = 0;
}
return(ch);
}
int _nxtdig(f) struct file *f; {
int ch;
_incpt(f);
ch = *f->ptr - '0';
if ((unsigned) ch > 9)
return(-1);
return(ch);
}
int _getint(f) struct file *f; {
int signed,i,ch;
signed = _getsig(f);
ch = _fstdig(f);
i = 0;
do
i = i*10 - ch;
while ((ch = _nxtdig(f)) >= 0);
return(signed ? i : -i);
}
int _rdi(f) struct file *f; {
_rf(f);
_skipsp(f);
return(_getint(f));
}

41
lang/pc/libpc/rdl.c
View File

@@ -1,41 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _rf();
extern _skipsp();
extern int _getsig();
extern int _fstdig();
extern int _nxtdig();
long _rdl(f) struct file *f; {
int signed,ch; long l;
_rf(f);
_skipsp(f);
signed = _getsig(f);
ch = _fstdig(f);
l = 0;
do
l = l*10 - ch;
while ((ch = _nxtdig(f)) >= 0);
return(signed ? l : -l);
}

78
lang/pc/libpc/rdr.c
View File

@@ -1,78 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
#define BIG 1e17
extern _rf();
extern _incpt();
extern _skipsp();
extern int _getsig();
extern int _getint();
extern int _fstdig();
extern int _nxtdig();
static double r;
static int pow10;
static dig(ch) int ch; {
if (r>BIG)
pow10++;
else
r = r*10.0 + ch;
}
double _rdr(f) struct file *f; {
int i; double e; int signed,ch;
r = 0;
pow10 = 0;
_rf(f);
_skipsp(f);
signed = _getsig(f);
ch = _fstdig(f);
do
dig(ch);
while ((ch = _nxtdig(f)) >= 0);
if (*f->ptr == '.') {
_incpt(f);
ch = _fstdig(f);
do {
dig(ch);
pow10--;
} while ((ch = _nxtdig(f)) >= 0);
}
if ((*f->ptr == 'e') || (*f->ptr == 'E')) {
_incpt(f);
pow10 += _getint(f);
}
if ((i = pow10) < 0)
i = -i;
e = 1.0;
while (--i >= 0)
e *= 10.0;
if (pow10<0)
r /= e;
else
r *= e;
return(signed? -r : r);
}

35
lang/pc/libpc/rf.c
View File

@@ -1,35 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
#include <pc_err.h>
extern struct file *_curfil;
extern _trp();
extern _incpt();
_rf(f) struct file *f; {
_curfil = f;
if ((f->flags&0377) != MAGIC)
_trp(EBADF);
if (f->flags & WRBIT)
_trp(EREADF);
if ((f->flags & WINDOW) == 0)
_incpt(f);
}

30
lang/pc/libpc/rln.c
View File

@@ -1,30 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _rf();
extern _incpt();
_rln(f) struct file *f; {
_rf(f);
while ((f->flags & ELNBIT) == 0)
_incpt(f);
f->flags &= ~WINDOW;
}

21
lang/pc/libpc/rnd.c
View File

@@ -1,21 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
double _rnd(r) double r; {
return(r + (r<0 ? -0.5 : 0.5));
}

49
lang/pc/libpc/sav.e
View File

@@ -1,49 +0,0 @@
#
; $Header$
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
/* Author: J.W. Stevenson */
mes 2,EM_WSIZE,EM_PSIZE
#define PTRAD 0
#define HP 2
; _sav called with one parameter:
; - address of pointer variable (PTRAD)
exp $_sav
pro $_sav,0
lor HP
lal PTRAD
loi EM_PSIZE
sti EM_PSIZE
ret 0
end ?
; _rst is called with one parameter:
; - address of pointer variable (PTRAD)
exp $_rst
pro $_rst,0
lal PTRAD
loi EM_PSIZE
loi EM_PSIZE
str HP
ret 0
end ?

34
lang/pc/libpc/sig.e
View File

@@ -1,34 +0,0 @@
#define PROC 0
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
; _sig is called with one parameter:
; - procedure instance identifier (PROC)
; and returns nothing.
; only the procedure identifier inside the PROC is used.
exp $_sig
pro $_sig,0
lal PROC
loi EM_PSIZE
sig
ret 0 ; ignore the result of sig
end ?

75
lang/pc/libpc/sin.c
View File

@@ -1,75 +0,0 @@
/* $Header$ */
extern double _fif();
/*
C program for floating point sin/cos.
Calls _fif.
There are no error exits.
Coefficients are #3370 from Hart & Cheney (18.80D).
*/
static double twoopi = 0.63661977236758134308;
static double p0 = .1357884097877375669092680e8;
static double p1 = -.4942908100902844161158627e7;
static double p2 = .4401030535375266501944918e6;
static double p3 = -.1384727249982452873054457e5;
static double p4 = .1459688406665768722226959e3;
static double q0 = .8644558652922534429915149e7;
static double q1 = .4081792252343299749395779e6;
static double q2 = .9463096101538208180571257e4;
static double q3 = .1326534908786136358911494e3;
static double
sinus(arg, quad)
double arg;
int quad;
{
double e, f;
double ysq;
double x,y;
int k;
double temp1, temp2;
x = arg;
if(x<0) {
x = -x;
quad = quad + 2;
}
x = x*twoopi; /*underflow?*/
if(x>32764){
y = _fif(x, 10.0, &e);
e = e + quad;
_fif(0.25, e, &f);
quad = e - 4*f;
}else{
k = x;
y = x - k;
quad = (quad + k) & 03;
}
if (quad & 01)
y = 1-y;
if(quad > 1)
y = -y;
ysq = y*y;
temp1 = ((((p4*ysq+p3)*ysq+p2)*ysq+p1)*ysq+p0)*y;
temp2 = ((((ysq+q3)*ysq+q2)*ysq+q1)*ysq+q0);
return(temp1/temp2);
}
double
_cos(arg)
double arg;
{
if(arg<0)
arg = -arg;
return(sinus(arg, 1));
}
double
_sin(arg)
double arg;
{
return(sinus(arg, 0));
}

60
lang/pc/libpc/sqt.c
View File

@@ -1,60 +0,0 @@
/* $Header$ */
#include <pc_err.h>
extern double _fef();
extern _trp();
/*
sqrt returns the square root of its floating
point argument. Newton's method.
calls _fef
*/
double
_sqt(arg)
double arg;
{
double x, temp;
int exp;
int i;
if(arg <= 0) {
if(arg < 0)
_trp(ESQT);
return(0);
}
x = _fef(arg,&exp);
/*
while(x < 0.5) {
x =* 2;
exp--;
}
*/
/*
* NOTE
* this wont work on 1's comp
*/
if(exp & 1) {
x *= 2;
exp--;
}
temp = 0.5*(1 + x);
while(exp > 28) {
temp *= (1<<14);
exp -= 28;
}
while(exp < -28) {
temp /= (1<<14);
exp += 28;
}
if(exp >= 0)
temp *= 1 << (exp/2);
else
temp /= 1 << (-exp/2);
for(i=0; i<=4; i++)
temp = 0.5*(temp + arg/temp);
return(temp);
}

60
lang/pc/libpc/string.c
View File

@@ -1,60 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* function strbuf(var b:charbuf):string; */
char *strbuf(s) char *s; {
return(s);
}
/* function strtobuf(s:string; var b:charbuf; blen:integer):integer; */
int strtobuf(s,b,l) char *s,*b; {
int i;
i = 0;
while (--l>=0) {
if ((*b++ = *s++) == 0)
break;
i++;
}
return(i);
}
/* function strlen(s:string):integer; */
int strlen(s) char *s; {
int i;
i = 0;
while (*s++)
i++;
return(i);
}
/* function strfetch(s:string; i:integer):char; */
int strfetch(s,i) char *s; {
return(s[i-1]);
}
/* procedure strstore(s:string; i:integer; c:char); */
strstore(s,i,c) char *s; {
s[i-1] = c;
}

33
lang/pc/libpc/trap.e
View File

@@ -1,33 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
#define TRAP 0
; trap is called with one parameter:
; - trap number (TRAP)
exp $trap
pro $trap,0
lol TRAP
trp
ret 0
end ?

38
lang/pc/libpc/trp.e
View File

@@ -1,38 +0,0 @@
#
; $Header$
;
; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
;
; This product is part of the Amsterdam Compiler Kit.
;
; Permission to use, sell, duplicate or disclose this software must be
; obtained in writing. Requests for such permissions may be sent to
;
; Dr. Andrew S. Tanenbaum
; Wiskundig Seminarium
; Vrije Universiteit
; Postbox 7161
; 1007 MC Amsterdam
; The Netherlands
;
;
mes 2,EM_WSIZE,EM_PSIZE
#define TRAP 0
; _trp() and trap() perform the same function,
; but have to be separate. trap exists to facilitate the user.
; _trp is there for the system, trap cannot be used for that purpose
; because a user might define its own Pascal routine called trap.
; _trp is called with one parameter:
; - trap number (TRAP)
exp $_trp
pro $_trp,0
lol TRAP
trp
ret 0
end ?

50
lang/pc/libpc/unp.c
View File

@@ -1,50 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_err.h>
extern _trp();
#define assert() /* nothing */
struct descr {
int low;
int diff;
int size;
};
_unp(ad,zd,i,ap,zp) int i; struct descr *ad,*zd; char *ap,*zp; {
if (zd->diff > ad->diff ||
(i -= ad->low) < 0 ||
(i+zd->diff) > ad->diff)
_trp(EUNPACK);
ap += (i * ad->size);
i = (zd->diff + 1) * zd->size;
if (zd->size == 1) {
assert(ad->size == 2);
while (--i >= 0)
*((int *)ap)++ = *zp++;
} else {
assert(ad->size == zd->size);
while (--i >= 0)
*ap++ = *zp++;
}
}

25
lang/pc/libpc/uread.c
View File

@@ -1,25 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* function uread(fd:integer; var b:buf; n:integer):integer; */
extern int read();
int uread(fd,b,n) char *b; int fd,n; {
return(read(fd,b,n));
}

25
lang/pc/libpc/uwrite.c
View File

@@ -1,25 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* function uwrite(fd:integer; var b:buf; n:integer):integer; */
extern int write();
int uwrite(fd,b,n) char *b; int fd,n; {
return(write(fd,b,n));
}

30
lang/pc/libpc/wdw.c
View File

@@ -1,30 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern struct file *_curfil;
extern _incpt();
char *_wdw(f) struct file *f; {
_curfil = f;
if ((f->flags & (WINDOW|WRBIT|0377)) == MAGIC)
_incpt(f);
return(f->ptr);
}

32
lang/pc/libpc/wf.c
View File

@@ -1,32 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
#include <pc_err.h>
extern struct file *_curfil;
extern _trp();
_wf(f) struct file *f; {
_curfil = f;
if ((f->flags&0377) != MAGIC)
_trp(EBADF);
if ((f->flags & WRBIT) == 0)
_trp(EWRITEF);
}

41
lang/pc/libpc/wrc.c
View File

@@ -1,41 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _wf();
extern _outcpt();
_wrc(c,f) int c; struct file *f; {
*f->ptr = c;
_wf(f);
_outcpt(f);
}
_wln(f) struct file *f; {
#ifdef CPM
_wrc('\r',f);
#endif
_wrc('\n',f);
f->flags |= ELNBIT;
}
_pag(f) struct file *f; {
_wrc('\014',f);
f->flags |= ELNBIT;
}

61
lang/pc/libpc/wrf.c
View File

@@ -1,61 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _wstrin();
extern char *_fcvt();
#define assert() /* nothing */
#define HUGE_DIG 39 /* log10(maxreal) */
#define PREC_DIG 80 /* the maximum digits returned by _fcvt() */
#define FILL_CHAR '0' /* char printed if all of _fcvt() used */
#define BUFSIZE HUGE_DIG + PREC_DIG + 2
_wrf(n,w,r,f) int n,w; double r; struct file *f; {
char *p,*b; int s,d; char buf[BUFSIZE];
p = buf;
if (n > PREC_DIG)
n = PREC_DIG;
b = _fcvt(r,n,&d,&s);
assert(abs(d) <= HUGE_DIG);
if (s)
*p++ = '-';
if (d<=0)
*p++ = '0';
else
do
*p++ = (*b ? *b++ : FILL_CHAR);
while (--d > 0);
if (n > 0)
*p++ = '.';
while (++d <= 0) {
if (--n < 0)
break;
*p++ = '0';
}
while (--n >= 0) {
*p++ = (*b ? *b++ : FILL_CHAR);
assert(p <= buf+BUFSIZE);
}
_wstrin(w,p-buf,buf,f);
}

44
lang/pc/libpc/wri.c
View File

@@ -1,44 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _wstrin();
_wsi(w,i,f) int w,i; struct file *f; {
char *p; int j; char buf[6];
p = &buf[6];
if ((j=i) < 0) {
if (i == -32768) {
_wstrin(w,6,"-32768",f);
return;
}
j = -j;
}
do
*--p = '0' + j%10;
while (j /= 10);
if (i<0)
*--p = '-';
_wstrin(w,&buf[6]-p,p,f);
}
_wri(i,f) int i; struct file *f; {
_wsi(6,i,f);
}

49
lang/pc/libpc/wrl.c
View File

@@ -1,49 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _wstrin();
#define MAXNEGLONG -2147483648
_wsl(w,l,f) int w; long l; struct file *f; {
char *p,c; long j; char buf[11];
p = &buf[11];
if ((j=l) < 0) {
if (l == MAXNEGLONG) {
_wstrin(w,11,"-2147483648",f);
return;
}
j = -j;
}
do {
c = j%10;
*--p = c + '0';
} while (j /= 10);
if (l<0)
*--p = '-';
_wstrin(w,&buf[11]-p,p,f);
}
_wrl(l,f) long l; struct file *f; {
_wsl(11,l,f);
}

56
lang/pc/libpc/wrr.c
View File

@@ -1,56 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _wstrin();
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];
p = buf;
if ((i = w-6) < 2)
i = 2;
b = _ecvt(r,i,&d,&s);
*p++ = s? '-' : ' ';
if (*b == '0')
d++;
*p++ = *b++;
*p++ = '.';
while (--i > 0)
*p++ = *b++;
*p++ = 'e';
d--;
if (d < 0) {
d = -d;
*p++ = '-';
} else
*p++ = '+';
*p++ = '0' + (d/10);
*p++ = '0' + (d%10);
_wstrin(w,p-buf,buf,f);
}
_wrr(r,f) double r; struct file *f; {
_wsr(13,r,f);
}

62
lang/pc/libpc/wrs.c
View File

@@ -1,62 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
/* Author: J.W. Stevenson */
#include <pc_file.h>
extern _wf();
extern _outcpt();
_wstrin(width,len,buf,f) int width,len; char *buf; struct file *f; {
_wf(f);
for (width -= len; width>0; width--) {
*f->ptr = ' ';
_outcpt(f);
}
while (--len >= 0) {
*f->ptr = *buf++;
_outcpt(f);
}
}
_wsc(w,c,f) int w; char c; struct file *f; {
_wss(w,1,&c,f);
}
_wss(w,len,s,f) int w,len; char *s; struct file *f; {
if (w < len)
len = w;
_wstrin(w,len,s,f);
}
_wrs(len,s,f) int len; char *s; struct file *f; {
_wss(len,len,s,f);
}
_wsb(w,b,f) int w,b; struct file *f; {
if (b)
_wss(w,4,"true",f);
else
_wss(w,5,"false",f);
}
_wrb(b,f) int b; struct file *f; {
_wsb(5,b,f);
}

36
lang/pc/libpc/wrz.c
View File

@@ -1,36 +0,0 @@
/* $Header$ */
/*
* (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
*
* This product is part of the Amsterdam Compiler Kit.
*
* Permission to use, sell, duplicate or disclose this software must be
* obtained in writing. Requests for such permissions may be sent to
*
* Dr. Andrew S. Tanenbaum
* Wiskundig Seminarium
* Vrije Universiteit
* Postbox 7161
* 1007 MC Amsterdam
* The Netherlands
*
*/
#include <pc_file.h>
extern _wss();
extern _wrs();
_wsz(w,s,f) int w; char *s; struct file *f; {
char *p;
for (p=s; *p; p++);
_wss(w,p-s,s,f);
}
_wrz(s,f) char *s; struct file *f; {
char *p;
for (p=s; *p; p++);
_wrs(p-s,s,f);
}

44
lang/pc/pem/Makefile
View File

@@ -1,44 +0,0 @@
# $Header$
d=../../..
h=$d/h
PEM=$d/lib/pc_pem
PEM_OUT=$d/lib/pc_pem.out
HEAD=$h/em_spec.h $h/em_pseu.h $h/em_mnem.h $h/em_mes.h $h/pc_size.h
LDFLAG=-i
all: pem pem.out
pem.out: pem.m
apc -mint --t -o pem.out pem.m
pem: pem.m
apc $(LDFLAG) -o pem pem.m
# pem.m is system dependent and may NOT be distributed
pem.m: pem.p $(HEAD)
-rm -f pem.m
-if apc -I$h -O -c.m pem.p ; then :; else \
acc -o move move.c ; move ; rm -f move move.[oskm] ; \
fi
cmp: pem
cmp pem $(PEM)
install: pem
cp pem $(PEM)
distr:
ln pem.p pem22.p ; apc -mpdp -c.m -I$h pem22.p ; rm -f pem22.p
ln pem.p pem24.p ; apc -mvax2 -c.m -I$h pem24.p ; rm -f pem24.p
clean:
-rm -f pem pem.out *.[os] *.old
pr:
@pr pem.p
xref:
xref pem.p^pr -h "XREF PEM.P"
opr:
make pr ^ opr

20
lang/pc/pem/move.c
View File

@@ -1,20 +0,0 @@
/* A program to move the file pem??.m to pem.m */
/* Called when "apc pem.p" fails. It is assumed that the binary
file is incorrect in that case and has to be created from the compact
code file.
This program selects the correct compact code file for each combination
of word and pointer size.
It will return an error code if the move failed
*/
main(argc) {
char copy[100] ;
if ( argc!=1 ) {
printf("No arguments allowed\n") ;
exit(1) ;
}
sprintf(copy,"cp pem%d%d.m pem.m", EM_WSIZE, EM_PSIZE) ;
printf("%s\n",copy) ;
return system(copy) ;
}

34
lang/pc/test/Makefile
View File

@@ -1,34 +0,0 @@
# $Header$
all: testC testI
testI:
# int t1.p; em
int t2.p; em
int t3.p; em e.out f1 f2 f3 f4 f5 f6
int t4.p; em
int t5.p; em
int tstenc.p; em
int tstgto.p; em
rm -f e.out f?
testC:
apc t1.p; a.out
apc t2.p; a.out
apc t3.p; a.out f1 f2 f3 f4 f5 f6
apc t4.p; a.out
apc t5.p; a.out
apc tstenc.p; a.out
apc tstgto.p; a.out
rm -f a.out f?
install cmp:
clean:
-rm -f [ea].out f?
opr:
make pr | opr
pr:
@pr t[12345].p tstenc.p

226
lang/pc/test/machar.p
View File

@@ -1,226 +0,0 @@
{ $Header$ }
procedure machar (var ibeta , it , irnd , ngrd , machep , negep , iexp,
minexp , maxexp : integer ; var eps , epsneg , xmin , xmax : real ) ;
var trapped:boolean;
procedure encaps(procedure p; procedure q(i:integer)); extern;
procedure trap(i:integer); extern;
procedure catch(i:integer);
const underflo=5;
begin if i=underflo then trapped:=true else trap(i) end;
procedure work;
var
{ This subroutine is intended to determine the characteristics
of the floating-point arithmetic system that are specified
below. The first three are determined according to an
algorithm due to M. Malcolm, CACM 15 (1972), pp. 949-951,
incorporating some, but not all, of the improvements
suggested by M. Gentleman and S. Marovich, CACM 17 (1974),
pp. 276-277. The version given here is for single precision.
Latest revision - October 1, 1976.
Author - W. J. Cody
Argonne National Laboratory
Revised for Pascal - R. A. Freak
University of Tasmania
Hobart
Tasmania
ibeta is the radix of the floating-point representation
it is the number of base ibeta digits in the floating-point
significand
irnd = 0 if the arithmetic chops,
1 if the arithmetic rounds
ngrd = 0 if irnd=1, or if irnd=0 and only it base ibeta
digits participate in the post normalization shift
of the floating-point significand in multiplication
1 if irnd=0 and more than it base ibeta digits
participate in the post normalization shift of the
floating-point significand in multiplication
machep is the exponent on the smallest positive floating-point
number eps such that 1.0+eps <> 1.0
negeps is the exponent on the smallest positive fl. pt. no.
negeps such that 1.0-negeps <> 1.0, except that
negeps is bounded below by it-3
iexp is the number of bits (decimal places if ibeta = 10)
reserved for the representation of the exponent of
a floating-point number
minexp is the exponent of the smallest positive fl. pt. no.
xmin
maxexp is the exponent of the largest finite floating-point
number xmax
eps is the smallest positive floating-point number such
that 1.0+eps <> 1.0. in particular,
eps = ibeta**machep
epsneg is the smallest positive floating-point number such
that 1.0-eps <> 1.0 (except that the exponent
negeps is bounded below by it-3). in particular
epsneg = ibeta**negep
xmin is the smallest positive floating-point number. in
particular, xmin = ibeta ** minexp
xmax is the largest finite floating-point number. in
particular xmax = (1.0-epsneg) * ibeta ** maxexp
note - on some machines xmax will be only the
second, or perhaps third, largest number, being
too small by 1 or 2 units in the last digit of
the significand.
}
i , iz , j , k , mx : integer ;
a , b , beta , betain , betam1 , one , y , z , zero : real ;
begin
irnd := 1 ;
one := ( irnd );
a := one + one ;
b := a ;
zero := 0.0 ;
{
determine ibeta,beta ala Malcolm
}
while ( ( ( a + one ) - a ) - one = zero ) do begin
a := a + a ;
end ;
while ( ( a + b ) - a = zero ) do begin
b := b + b ;
end ;
ibeta := trunc ( ( a + b ) - a );
beta := ( ibeta );
betam1 := beta - one ;
{
determine irnd,ngrd,it
}
if ( ( a + betam1 ) - a = zero ) then irnd := 0 ;
it := 0 ;
a := one ;
repeat begin
it := it + 1 ;
a := a * beta ;
end until ( ( ( a + one ) - a ) - one <> zero ) ;
{
determine negep, epsneg
}
negep := it + 3 ;
a := one ;
for i := 1 to negep do begin
a := a / beta ;
end ;
while ( ( one - a ) - one = zero ) do begin
a := a * beta ;
negep := negep - 1 ;
end ;
negep := - negep ;
epsneg := a ;
{
determine machep, eps
}
machep := negep ;
while ( ( one + a ) - one = zero ) do begin
a := a * beta ;
machep := machep + 1 ;
end ;
eps := a ;
{
determine ngrd
}
ngrd := 0 ;
if(( irnd = 0) and((( one + eps) * one - one) <> zero)) then
ngrd := 1 ;
{
determine iexp, minexp, xmin
loop to determine largest i such that
(1/beta) ** (2**(i))
does not underflow
exit from loop is signall by an underflow
}
i := 0 ;
betain := one / beta ;
z := betain ;
trapped:=false;
repeat begin
y := z ;
z := y * y ;
{
check for underflow
}
i := i + 1 ;
end until trapped;
i := i - 1;
k := 1 ;
{
determine k such that (1/beta)**k does not underflow
first set k = 2 ** i
}
for j := 1 to i do begin
k := k + k ;
end ;
iexp := i + 1 ;
mx := k + k ;
if ( ibeta = 10 ) then begin
{
for decimal machines only }
iexp := 2 ;
iz := ibeta ;
while ( k >= iz ) do begin
iz := iz * ibeta ;
iexp := iexp + 1 ;
end ;
mx := iz + iz - 1 ;
end;
trapped:=false;
repeat begin
{
loop to construct xmin
exit from loop is signalled by an underflow
}
xmin := y ;
y := y * betain ;
k := k + 1 ;
end until trapped;
k := k - 1;
minexp := - k ;
{ determine maxexp, xmax
}
if ( ( mx <= k + k - 3 ) and ( ibeta <> 10 ) ) then begin
mx := mx + mx ;
iexp := iexp + 1 ;
end;
maxexp := mx + minexp ;
{ adjust for machines with implicit leading
bit in binary significand and machines with
radix point at extreme right of significand
}
i := maxexp + minexp ;
if ( ( ibeta = 2 ) and ( i = 0 ) ) then maxexp := maxexp - 1 ;
if ( i > 20 ) then maxexp := maxexp - 3 ;
xmax := one - epsneg ;
if ( xmax * one <> xmax ) then xmax := one - beta * epsneg ;
xmax := ( xmax * betain * betain * betain ) / xmin ;
i := maxexp + minexp + 3 ;
if ( i > 0 ) then begin
for j := 1 to i do begin
xmax := xmax * beta ;
end ;
end;
end;
begin
trapped:=false;
encaps(work,catch);
end;

677
lang/pc/test/t1.p
View File

@@ -1,677 +0,0 @@
#
{
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
This product is part of the Amsterdam Compiler Kit.
Permission to use, sell, duplicate or disclose this software must be
obtained in writing. Requests for such permissions may be sent to
Dr. Andrew S. Tanenbaum
Wiskundig Seminarium
Vrije Universiteit
Postbox 7161
1007 MC Amsterdam
The Netherlands
}
program t1(input,output);
{ This program can be used to test out PASCAL compilers }
const
rcsversion='$Header$';
ONE=1; TWO=2; TEN=10; FIFTY=50; MINONE=-1;
#ifndef NOFLOAT
RR1=1.0; RR1H=1.5; RR2=2.0; RR3=3.0; RR4=4.0; RRMINONE=-1.0;
#endif
yes=true; no=false;
kew='q';
#ifndef NOFLOAT
eps = 2.0e-7; { This constant is machine dependent }
#endif
type wavelength = (red,blue,yellow,purple,white,gray,pink,black,fuchia,maple,
violet,darkred,darkblue,darkyellow,darkwhite,darkpink,darkblack);
ww2= 1939..1945;
#ifndef NOFLOAT
tp2= record c1:char; i,j:integer; p:boolean; x:real end;
#else
tp2= record c1:char; i,j:integer; p:boolean end;
#endif
single= array [0..0] of integer;
spectrum= set of wavelength;
np = ^node;
node = record val:integer; next: np end;
var t,pct,ect:integer;
i,j,k,l,m:integer;
#ifndef NOFLOAT
x,y,z:real;
#endif
p,q,r:boolean;
c1,c2,c3:char;
sr1,sr2,sr3: 1939..1945;
bar: packed array[0..3] of 0..255;
color,hue,tint: wavelength;
grat:spectrum;
a1: array [-10..+10] of integer;
#ifndef NOFLOAT
a2: array [ww2] of real;
#endif
a3: array[wavelength] of boolean;
a4: array[(mouse,house)] of char;
a5: array[50..52,(bat,cat),boolean,ww2] of integer;
a6: packed array[0..10,0..3,0..3] of char;
r1,r2: tp2;
#ifndef NOFLOAT
r3: packed record c1:char; i,j:integer; p:boolean; x:real end;
#else
r3: packed record c1:char; i,j:integer; p:boolean end;
#endif
colors: set of wavelength;
beasts: set of (pig,cow,chicken,farmersdaughter);
bits: set of 0..1;
p1: ^integer;
p2: ^tp2;
p3: ^single;
p4: ^spectrum;
head,tail: np;
procedure e(n:integer);
begin
ect := ect + 1;
writeln(' Error', n:3,' in test ', t)
end;
function inc(k:integer):integer; begin inc := k+1 end;
{************************************************************************}
procedure tst1;
{ Arithmetic on constants }
begin t:=1; pct := pct + 1;
if 1+1 <> 2 then e(1);
if ONE+ONE <> TWO then e(2);
if ONE+MINONE <> 0 then e(3);
if ONE-TWO <> MINONE then e(4);
if TWO-MINONE <> 3 then e(5);
if TWO*TWO <> 4 then e(6);
if 100*MINONE <> -100 then e(7);
if 50*ONE <> 50 then e(8);
if 50*9 <> 450 then e(9);
if 50*TEN <> 500 then e(10);
if 60 div TWO <> 30 then e(11);
if FIFTY div TWO <> 25 then e(12);
if -2 div 1 <> -2 then e(13);
if -3 div 1 <> -3 then e(14);
if -3 div 2 <> -1 then e(15);
if ((1+2+3) * (2+3+4) * (3+5+5)) div 2 <> ((3 * ((5+3+2)*10)+51)*6) div 6
then e(16);
if (1000*2 + 5*7 + 13) div 8 <> 2*2*2*2*4*4 then e(17);
if (1 * 2 * 3 * 4 * 5 * 6 * 7) div 5040 <>
5040 div 7 div 6 div 5 div 4 div 3 div 2 then e(18);
if -(-(-(-(-(-(-(-(-(1))))))))) <> -1 then e(19);
if -1 -1 -1 -1 -1 <> -5 then e(20);
if - 1 <> -(((((((((((((1))))))))))))) then e(21);
if -4 * (-5) <> 20 then e(22);
if (9999-8) mod 97 <> 309 mod 3 then e(23);
if 2<1 then e(24);
if 2 <= 1 then e(25);
if 2 = 3 then e(26);
if 2 <> 2 then e(27);
if 2 >= 3 then e(28);
if 2 > 3 then e(29);
if 2+0 <> 2 then e(30);
if 2-0 <> 2 then e(31);
if 2*0 <> 0 then e(32);
if 0+2 <> 2 then e(33);
if 0-2 <> -2 then e(34);
if 0*2 <> 0 then e(35);
if 0 div 1 <> 0 then e(36);
if -0 <> 0 then e(37);
if 0 - 0 <> 0 then e(38);
if 0 * 0 <> 0 then e(39);
end;
{************************************************************************}
procedure tst2;
{ Arithmetic on global integer variables }
begin t:=2; pct := pct + 1;
i:=1; j:=2; k:=3; l:=4; m:=10;
if i+j <> k then e(1);
if i+k <> l then e(2);
if j-k <> -i then e(3);
if j*(j+k) <> m then e(4);
if -m <> -(k+k+l) then e(5);
if i div i <> 1 then e(6);
if m*m div m <> m then e(7);
if 10*m <> 100 then e(8);
if m*(-10) <> -100 then e(9);
if j div k <> 0 then e(10);
if 100 div k <> 33 then e(11);
if i+j*k+l+m mod j + 50 div k <> 27 then e(12);
if j*k*m div 6 <> 10 then e(13);
if (k>4) or (k>=4) or (k=4) then e(14);
if (m<j) or (m<=j) or (m=j) then e(15);
if k <> i+j then e(16);
if j < i then e(17);
if j <= i then e(18);
if j = i then e(19);
if j <> j then e(20);
if i >= j then e(21);
if i > j then e(22);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst3;
{ Real arithmetic }
begin t:=3; pct := pct + 1;
if abs(1.0+1.0-2.0) > eps then e(1);
if abs(1e10-1e10) > eps then e(2);
if abs(RR1+RR1H+RR2+RR3+RR4+RRMINONE-10.5) > eps then e(3);
if abs(1.0e-1 * 1.0e1 - 100e-2) > eps then e(4);
if abs(10.0/3.0*3.0/10.0-100e-2) > eps then e(5);
if 0.0e0 <> 0 then e(6);
if abs(32767.0-32767.0) > eps then e(7);
if abs(1.0+2+5+3.0e0+5.0e+0+140e-1-30.000)/100 > eps then e(8);
if abs(-1+(-1)+(-1.0)+(-1e0)+(-1e+0)+(-1e-0) + ((((6)))) ) > eps then e(9);
x:=1.50; y:=3.00; z:= 0.10;
if abs(5*y*z-x) > eps then e(10);
if abs(y*y*y/z*x-405) > eps then e(11);
x:=1.1; y:= 1.2;
if y<x then e(12);
if y <= x then e(13);
if y = x then e(14);
if x <> x then e(15);
if x >= y then e(16);
if x >y then e(17);
end;
#endif
{************************************************************************}
procedure tst4;
{ Boolean expressions }
begin t:=4; pct := pct + 1;
if not yes = true then e(1);
if not no = false then e(2);
if yes = no then e(3);
if not true = not false then e(4);
if true and false then e(5);
if false or false then e(6);
p:=true; q:=true; r:=false;
if not p then e(7);
if r then e(8);
if p and r then e(9);
if p and not q then e(10);
if not p or not q then e(11);
if (p and r) or (q and r) then e(12);
if p and q and r then e(13);
if (p or q) = r then e(14);
end;
{************************************************************************}
procedure tst5;
{ Characters, Subranges, Enumerated types }
begin t:=5; pct := pct + 1;
if 'q' <> kew then e(1);
c1 := 'a'; c2 := 'b'; c3 := 'a';
if c1 = c2 then e(2);
if c1 <> c3 then e(3);
sr1:=1939; sr2:=1945; sr3:=1939;
if sr1=sr2 then e(4);
if sr1<>sr3 then e(5);
color := yellow; hue := blue; tint := yellow;
if color = hue then e(6);
if color <> tint then e(7);
end;
{************************************************************************}
procedure tst6;
{ Global arrays }
var i,j,k:integer;
begin t:=6; pct := pct + 1;
for i:= -10 to 10 do a1[i] := i*i;
if (a1[-10]<>100) or (a1[9]<>81) then e(1);
#ifndef NOFLOAT
for i:=1939 to 1945 do a2[i]:=i-1938.5;
if (abs(a2[1939]-0.5) > eps) or (abs(a2[1945]-6.5) > eps) then e(2);
#endif
color := yellow;
a3[blue] := true; a3[yellow] := true;
if (a3[blue]<>true) or (a3[yellow]<>true) then e(3);
a3[blue] := false; a3[yellow] := false;
if (a3[blue]<>false) or (a3[yellow]<>false) then e(4);
a4[mouse]:='m'; a4[house]:='h';
if (a4[mouse] <> 'm') or (a4[house]<>'h' ) then e(5);
for i:=1939 to 1945 do a5[51,bat,false,i]:=300+i;
if a5[51,bat,false,1940] <> 2240 then e(6);
for i:=50 to 52 do a5[i,cat,true,1943]:=200+i;
if (a5[50,cat,true,1943] <> 250) or (a5[52,cat,true,1943] <> 252) then e(7);
for i:= -10 to 10 do a1[i]:= 0;
for i:= 0 to 10 do a1[i div 2 + i div 2]:= i+1;
if(a1[0]<>2) or (a1[5]<>0) or (a1[8]<>10) then e(8);
for i:= 0 to 10 do
for j:= 0 to 3 do
for k:= 0 to 3 do
if ( (i+j+k) div 2) * 2 = i+j+k then a6[i,j,k]:='e' else a6[i,j,k]:='o';
if (a6[2,2,2]<>'e') or (a6[2,2,3]<>'o') or (a6[0,3,1]<>'e') then e(9);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst7;
{ Global records }
begin t:=7; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true; r1.x:=3.0;
c1:='a'; i:=0; j:=0; p:=false; x:=100.0;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) or (r1.x<>3.0) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) or (r2.x<>3.0) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1; x:=r1.x;
if (c1<>'x') or (i<>40) or (p<>true) or (x<>3.0) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true; r3.x:=3.0;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) or (r3.x<>3.0) then e(4);
end;
#else
{************************************************************************}
procedure tst7;
{ Global records }
begin t:=7; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true;
c1:='a'; i:=0; j:=0; p:=false;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1;
if (c1<>'x') or (i<>40) or (p<>true) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) then e(4);
end;
#endif
{************************************************************************}
procedure tst8;
{ Global sets }
begin t:=8; pct := pct + 1;
colors := [];
colors := colors + [];
if colors <> [] then e(1);
colors := colors + [red];
if colors <> [red] then e(2);
colors := colors + [blue];
if colors <> [red,blue] then e(3);
if colors <> [blue,red] then e(4);
colors := colors - [red];
if colors <> [blue] then e(5);
beasts := [chicken] + [chicken,pig];
if beasts <> [pig,chicken] then e(6);
beasts := [] - [farmersdaughter] + [cow] - [cow];
if beasts <> [] then e(7);
bits := [0] + [1] - [0];
if bits <> [1] then e(8);
bits := [] + [] + [] -[] + [0] + [] + [] - [0];
if bits <> [] then e(9);
if not ([] <= [red]) then e(10);
if [red] >= [blue] then e(11);
if [red] <= [blue] then e(12);
if [red] = [blue] then e(13);
if not ([red] <= [red,blue]) then e(14);
if not ([red,blue] <= [red,yellow,blue]) then e(15);
if not ([blue,yellow] >= [blue] + [yellow]) then e(16);
grat := [ red,blue,yellow,purple,white,gray,pink,black,fuchia,maple,
violet,darkred,darkblue,darkyellow,darkwhite,darkpink,darkblack];
if grat<>[red,blue,yellow,purple,white,gray,pink,black,fuchia,maple,violet,
darkred,darkblue,darkyellow,darkwhite,darkpink,darkblack] then e(17);
if not ([10] <= [10]) then e(18);
end;
{************************************************************************}
procedure tst9;
{ Global pointers }
begin t:=9; pct := pct + 1;
new(p1); new(p2); new(p3); new(p4);
p1^ := 1066;
if p1^ <> 1066 then e(1);
p2^.i := 1215;
if p2^.i <> 1215 then e(2);
p3^[0]:= 1566;
if p3^[0] <> 1566 then e(3);
p4^ := [red];
if p4^ <> [red] then e(4);
end;
{************************************************************************}
procedure tst10;
{ More global pointers }
var i:integer;
begin t:=10; pct := pct + 1;
head := nil;
for i:= 1 to 100 do
begin new(tail); tail^.val:=100+i; tail^.next :=head; head:= tail end;
if (tail^.val<>200) or (tail^.next^.val<>199) then e(1);
if tail^.next^.next^.next^.next^.next^.next^.next^.next^.val<> 192 then e(2);
tail^.next^.next^.next^.val := 30;
if tail^.next^.next^.next^.val <> 30 then e(3);
end;
{************************************************************************}
procedure tst11;
{ Arithmetic on local integer variables }
var i,j,k,l,m:integer;
begin t:=11; pct := pct + 1;
i:=1; j:=2; k:=3; l:=4; m:=10;
if i+j <> k then e(1);
if i+k <> l then e(2);
if j-k <> -i then e(3);
if j*(j+k) <> m then e(4);
if -m <> -(k+k+l) then e(5);
if i div i <> 1 then e(6);
if m*m div m <> m then e(7);
if 10*m <> 100 then e(8);
if m*(-10) <> -100 then e(9);
if j div k <> 0 then e(10);
if 100 div k <> 33 then e(11);
if i+j*k+l+m mod j + 50 div k <> 27 then e(12);
if j*k*m div 6 <> 10 then e(13);
if (k>4) or (k>=4) or (k=4) then e(14);
if (m<j) or (m<=j) or (m=j) then e(15);
if k <> i+j then e(16);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst12;
{ Real arithmetic on locals }
var x,y,z:real;
begin t:=12; pct := pct + 1;
x:=1.50; y:=3.00; z:= 0.10;
if abs(5*y*z-x) > eps then e(10);
if abs(y*y*y/z*x-405) > eps then e(11);
x:=1.1; y:= 1.2;
if y<x then e(12);
if y <= x then e(13);
if y = x then e(14);
if x <> x then e(15);
if x >= y then e(16);
if x >y then e(17);
end;
#endif
{************************************************************************}
procedure tst13;
{ Boolean expressions using locals }
var pp,qq,rr:boolean;
begin t:=13; pct := pct + 1;
if not yes = true then e(1);
if not no = false then e(2);
if yes = no then e(3);
if not true = not false then e(4);
if true and false then e(5);
if false or false then e(6);
pp:=true; qq:=true; rr:=false;
if not pp then e(7);
if rr then e(8);
if pp and rr then e(9);
if pp and not qq then e(10);
if not pp or not qq then e(11);
if (pp and rr) or (qq and rr) then e(12);
if pp and qq and rr then e(13);
if (pp or qq) = rr then e(14);
end;
{************************************************************************}
procedure tst14;
{ Characters, Subranges, Enumerated types using locals }
var cc1,cc2,cc3:char;
sr1,sr2,sr3: 1939..1945;
color,hue,tint: (ochre,magenta);
begin t:=14; pct := pct + 1;
if 'q' <> kew then e(1);
cc1 := 'a'; cc2 := 'b'; cc3 := 'a';
if cc1 = cc2 then e(2);
if cc1 <> cc3 then e(3);
sr1:=1939; sr2:=1945; sr3:=1939;
if sr1=sr2 then e(4);
if sr1<>sr3 then e(5);
bar[0]:=200; bar[1]:=255; bar[2]:=255; bar[3]:=203;
if (bar[0]<>200) or (bar[1]<>255) or (bar[2]<>255) or (bar[3]<>203) then e(6);
color := ochre; hue:=magenta; tint := ochre;
if color = hue then e(7);
if color <> tint then e(8);
end;
{************************************************************************}
procedure tst15;
{ Local arrays }
type colour = (magenta,ochre);
var aa1: array [-10..+10] of integer;
#ifndef NOFLOAT
aa2: array [ww2] of real;
#endif
aa3: array[colour] of boolean;
aa4: array[(mouse,house,louse)] of char;
aa5: array[50..52,(bat,cat),boolean,ww2] of integer;
aa6: packed array[0..10,0..3,0..3] of char;
i,j,k:integer;
begin t:=15; pct := pct + 1;
for i:= -10 to 10 do aa1[i] := i*i;
if (aa1[-10]<>100) or (aa1[9]<>81) then e(1);
#ifndef NOFLOAT
for i:=1939 to 1945 do aa2[i]:=i-1938.5;
if (abs(aa2[1939]-0.5) > eps) or (abs(aa2[1945]-6.5) > eps) then e(2);
#endif
aa3[magenta] := true; aa3[ochre] := true;
if (aa3[magenta]<>true) or (aa3[ochre]<>true) then e(3);
aa3[magenta] := false; aa3[ochre] := false;
if (aa3[magenta]<>false) or (aa3[ochre]<>false) then e(4);
aa4[mouse]:='m'; aa4[house]:='h'; aa4[louse]:='l';
if (aa4[mouse] <> 'm') or (aa4[house]<>'h' ) or (aa4[louse]<>'l') then e(5);
for i:=1939 to 1945 do aa5[51,bat,false,i]:=300+i;
if aa5[51,bat,false,1940] <> 2240 then e(6);
for i:=50 to 52 do aa5[i,cat,true,1943]:=200+i;
if (aa5[50,cat,true,1943] <> 250) or (aa5[52,cat,true,1943] <> 252) then e(7);
for i:= -10 to 10 do aa1[i]:= 0;
for i:= 0 to 10 do aa1[i div 2 + i div 2]:= i+1;
if(aa1[0]<>2) or (aa1[5]<>0) or (aa1[8]<>10) then e(8);
for i:= 0 to 10 do
for j:= 0 to 3 do
for k:= 0 to 3 do
if ( (i+j+k) div 2) * 2 = i+j+k then aa6[i,j,k]:='e' else aa6[i,j,k]:='o';
if (aa6[2,2,2]<>'e') or (aa6[2,2,3]<>'o') or (aa6[0,3,1]<>'e') then e(9);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst16;
{ Local records }
var r1,r2: tp2;
r3: packed record c1:char; i,j:integer; p:boolean; x:real end;
begin t:=16; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true; r1.x:=3.0;
c1:='a'; i:=0; j:=0; p:=false; x:=100.0;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) or (r1.x<>3.0) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) or (r2.x<>3.0) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1; x:=r1.x;
if (c1<>'x') or (i<>40) or (p<>true) or (x<>3.0) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true; r3.x:=3.0;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) or (r3.x<>3.0) then e(4);
end;
#else
{************************************************************************}
procedure tst16;
{ Local records }
var r1,r2: tp2;
r3: packed record c1:char; i,j:integer; p:boolean end;
begin t:=16; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true;
c1:='a'; i:=0; j:=0; p:=false;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1;
if (c1<>'x') or (i<>40) or (p<>true) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) then e(4);
end;
#endif
{************************************************************************}
procedure tst17;
{ Local sets }
var colors: set of (pink,green,orange,red);
beasts: set of (pig,cow,chicken,farmersdaughter);
bits: set of 0..1;
begin t:=17; pct := pct + 1;
colors := [];
colors := colors + [];
if colors <> [] then e(1);
colors := colors + [pink];
if colors <> [pink] then e(2);
colors := colors + [green];
if colors <> [pink,green] then e(3);
if colors <> [green,pink] then e(4);
colors := colors - [pink,orange];
if colors <> [green] then e(5);
beasts := [chicken] + [chicken,pig];
if beasts <> [pig,chicken] then e(6);
beasts := [] - [farmersdaughter] + [cow] - [cow];
if beasts <> [] then e(7);
bits := [0] + [1] - [0];
if bits <> [1] then e(8);
bits := [] + [] + [] + [0] + [] + [0];
if bits <> [0] then e(9);
if ord(red) <> 3 then e(10);
end;
{************************************************************************}
procedure tst18;
{ Local pointers }
type rainbow = set of (pink,purple,chartreuse);
var p1: ^integer;
p2: ^tp2;
p3: ^single;
p4: ^rainbow;
begin t:=18; pct := pct + 1;
new(p1); new(p2); new(p3); new(p4);
p1^ := 1066;
if p1^ <> 1066 then e(1);
p2^.i := 1215;
if p2^.i <> 1215 then e(2);
p3^[0]:= 1566;
if p3^[0] <> 1566 then e(3);
p4^ := [pink] + [purple] + [purple,chartreuse] - [purple];
if p4^ <> [pink,chartreuse] then e(4);
end;
{************************************************************************}
procedure tst19;
var head,tail: np; i:integer;
begin t:=19; pct := pct + 1;
head := nil;
for i:= 1 to 100 do
begin new(tail); tail^.val:=100+i; tail^.next :=head; head:= tail end;
if (tail^.val<>200) or (tail^.next^.val<>199) then e(1);
if tail^.next^.next^.next^.next^.next^.next^.next^.next^.val<> 192 then e(2);
tail^.next^.next^.next^.val := 30;
if tail^.next^.next^.next^.val <> 30 then e(3);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst20;
{ Mixed local and global }
var li:integer;
lx:real;
begin t:=20; pct := pct + 1;
li:=6; i:=li; if i<>6 then e(1);
i:=6; li:=i; if li <> 6 then e(2);
lx := 3.5; x:=lx; if x <> 3.5 then e(3);
x:= 4.5; lx:= x; if lx <> 4.5 then e(4);
end;
#else
{************************************************************************}
procedure tst20;
{ Mixed local and global }
var li:integer;
begin t:=20; pct := pct + 1;
li:=6; i:=li; if i<>6 then e(1);
i:=6; li:=i; if li <> 6 then e(2);
end;
#endif
{************************************************************************}
{ Main Program }
begin ect := 0; pct := 0;
#ifndef NOFLOAT
tst1; tst2; tst3; tst4; tst5; tst6; tst7; tst8;
tst9; tst10; tst11; tst12; tst13; tst14; tst15; tst16;
tst17; tst18; tst19; tst20;
#else
tst1; tst2; tst4; tst5; tst6; tst7; tst8;
tst9; tst10; tst11; tst13; tst14; tst15; tst16;
tst17; tst18; tst19; tst20;
#endif
write('Program t1:',pct:3,' tests completed.');
writeln('Number of errors = ',ect:0);
end.

739
lang/pc/test/t2.p
View File

@@ -1,739 +0,0 @@
#
{
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
This product is part of the Amsterdam Compiler Kit.
Permission to use, sell, duplicate or disclose this software must be
obtained in writing. Requests for such permissions may be sent to
Dr. Andrew S. Tanenbaum
Wiskundig Seminarium
Vrije Universiteit
Postbox 7161
1007 MC Amsterdam
The Netherlands
}
program t2(input,output);
{ This program can be used to test out PASCAL compilers }
const
rcsversion='$Header$';
kew='q';
#ifndef NOFLOAT
eps = 2.0e-7; { This constant is machine dependent }
#endif
type wavelength = (red,blue,yellow);
tp2= record c1:char; i,j:integer; p:boolean; x:real end;
single= array [0..0] of integer;
spectrum= set of wavelength;
np= ^node;
node = record val:integer; next: np end;
var t,pct,ect:integer;
i,j,k,l:integer;
#ifndef NOFLOAT
w,x,y,z:real;
#endif
p:boolean;
d:char;
color: wavelength;
head: np;
function twice(k:integer):integer; begin twice := 2*k end;
function inc(k:integer):integer; begin inc := k+1 end;
procedure e(n:integer);
begin
ect := ect + 1;
writeln(' Error', n:3,' in test ', t)
end;
{************************************************************************}
procedure tst21;
{ Test things packed }
var i:integer; c:char;
r1: packed record c:char; b:boolean; i:integer end;
r2: packed record c:char; i:integer; b:boolean; j:integer end;
#ifndef NOFLOAT
r3: packed record c:char; r:real end;
#else
r3: packed record c:char end;
#endif
r4: packed record i:0..10; j:integer end;
r5: packed record x:array[1..3] of char; i:integer end;
r6: packed record x: packed array[1..3] of char; i:integer end;
r7: packed record c:char; x:packed array[1..3] of char end;
r8: packed record c:char; x:packed array[1..3] of integer end;
r9: record x:packed record c:char; i:integer end; i:integer; c:char end;
r10:packed record a:0..100; b:0..100; c:char; d:char end;
a1: packed array[1..3] of char;
a2: packed array[1..3] of integer;
#ifndef NOFLOAT
a3: packed array[1..7] of real;
#endif
a4: packed array[1..7] of array[1..11] of char;
a5: packed array[1..5] of array[1..11] of integer;
a6: packed array[1..9] of packed array[1..11] of char;
a7: packed array[1..3] of packed array[1..5] of integer;
begin t:=21; pct := pct + 1;
#ifndef NOFLOAT
i:=4; x:=3.5; c:='x'; p:=true;
#else
i:=4; c:='x'; p:=true;
#endif
r1.c:='a'; r1.b:=true; r1.i:=i; p:=r1.b; j:=r1.i;
r2.c:=c; r2.i:=i; r2.b:=p; r2.j:=i; j:=r2.i; j:=r2.j;
#ifndef NOFLOAT
r3.c:=c; r3.r:=x; y:=r3.r;
#else
r3.c:=c;
#endif
r4.i:=i; r4.j:=i; j:=r4.i; j:=r4.j;
r5.x[i-2]:=c; r5.i:=i; j:=r5.i;
r6.x[i-1]:=c; r6.i:=i; j:=r6.i;
r7.c:=c; r7.x[i-1]:=c; d:=r7.c; d:=r7.x[i-1];
r8.c:=c; r8.x[i-1]:=5; j:=r8.x[i-1];
r9.x.c:=c; r9.x.i:=i; r9.c:=c; j:=r9.x.i;
if (r1.c <> 'a') or (r1.b <> true) or (r1.i <> 4) then e(1);
if (r2.c<>'x') or (r2.i<>4) or (r2.b<>p) or (r2.j<>4) then e(2);
#ifndef NOFLOAT
if (r3.c<>'x') or (r3.r<>3.5) then e(3);
#else
if (r3.c<>'x') then e(3);
#endif
if (r4.i<>4) or (r4.j<>4) then e(4);
if (r5.x[2]<>'x') or (r5.i<>4) then e(5);
if (r6.x[3]<>'x') or (r6.i<>4) then e(6);
if (r7.c<>'x') or (r7.x[3]<>'x') or (c<>d) then e(7);
if (r8.c<>'x') or (r8.x[3]<>5) then e(8);
if (r9.x.c<>'x') or (r9.x.i<>4) or (r9.c<>'x') then e(9);
#ifndef NOFLOAT
i:=4; a1[i-1]:=c; a2[i-1]:=i; a3[i]:=x;
#else
i:=4; a1[i-1]:=c; a2[i-1]:=i;
#endif
a4[i][i+1]:=c;
a5[i][i+1]:=i; j:=a5[i][i+1];
a6[i][i+1]:=c;
a7[i-1][i+1]:=i; j:=a7[i-1][i+1];
if a1[i-1] <> 'x' then e(10);
if a2[i-1] <> 4 then e(11);
#ifndef NOFLOAT
if a3[i] <> 3.5 then e(12);
#endif
if a4[i][i+1] <> 'x' then e(13);
if a5[i][i+1] <> 4 then e(14);
if a6[i][i+1] <> 'x' then e(15);
if a7[i-1][i+1] <> 4 then e(16);
i:=75; c:='s';
r10.a:=i; r10.b:=i+1; r10.c:='x'; r10.d:=c;
if (r10.a<>i) or (r10.b<>76) or (r10.c<>'x') or (r10.d<>'s') then e(17);
i:=r10.a; if i<>75 then e(18);
i:=r10.b; if i<>76 then e(19);
c:=r10.c; if c<>'x'then e(20);
c:=r10.d; if c<>'s'then e(21);
end;
{************************************************************************}
procedure tst22;
{ References to intermediate lexical levels }
type wavelength = (pink,green,orange);
ww2= 1939..1945;
#ifndef NOFLOAT
tp2= record c1:char; i,j:integer; p:boolean; x:real end;
#else
tp2= record c1:char; i,j:integer; p:boolean end;
#endif
single= array [0..0] of integer;
spectrum= set of wavelength;
pnode = ^node;
node = record val:integer; next: pnode end;
vec1 = array[-10..+10] of integer;
var j,k,m:integer;
#ifndef NOFLOAT
x,y,z:real;
#endif
p,q,r:boolean;
c1,c2,c3:char;
sr1,sr2,sr3: 1939..1945;
color,hue,tint: wavelength;
a1: vec1;
#ifndef NOFLOAT
a2: array [ww2] of real;
#endif
a3: array[wavelength] of boolean;
a4: array[(mouse,house)] of char;
a5: array[50..52,(bat,cat,rat),boolean,ww2] of integer;
a6: packed array[0..10,0..3,0..3] of char;
r1,r2: tp2;
#ifndef NOFLOAT
r3: packed record c1:char; i,j:integer; p:boolean; x:real end;
#else
r3: packed record c1:char; i,j:integer; p:boolean end;
#endif
colors: spectrum;
beasts: set of (pig,chicken,farmersdaughter);
bits: set of 0..1;
p1: ^integer;
p2: ^tp2;
p3: ^single;
p4: ^spectrum;
tail: np;
procedure tst2201;
{ Arithmetic on intermediate level integer variables }
begin t:=2201; pct := pct + 1;
i:=1; j:=2; k:=3; l:=4; m:=10;
if i+j <> k then e(1);
if i+k <> l then e(2);
if j-k <> -i then e(3);
if j*(j+k) <> m then e(4);
if -m <> -(k+k+l) then e(5);
if i div i <> 1 then e(6);
if m*m div m <> m then e(7);
if 10*m <> 100 then e(8);
if m*(-10) <> -100 then e(9);
if j div k <> 0 then e(10);
if 100 div k <> 33 then e(11);
if i+j*k+l+m mod j + 50 div k <> 27 then e(12);
if j*k*m div 6 <> 10 then e(13);
if (k>4) or (k>=4) or (k=4) then e(14);
if (m<j) or (m<=j) or (m=j) then e(15);
if k <> i+j then e(16);
end;
#ifndef NOFLOAT
procedure tst2202;
{ Real arithmetic using intermediate level variables }
begin t:=2202; pct := pct + 1;
x:=1.50; y:=3.00; z:= 0.10;
if abs(5*y*z-x) > eps then e(10);
if abs(y*y*y/z*x-405) > eps then e(11);
x:=1.1; y:= 1.2;
if y<x then e(12);
if y <= x then e(13);
if y = x then e(14);
if x <> x then e(15);
if x >= y then e(16);
if x >y then e(17);
end;
#endif
procedure tst2203;
{ Boolean expressions using intermediate level varibales }
begin t:=2203; pct := pct + 1;
p:=true; q:=true; r:=false;
if not p then e(7);
if r then e(8);
if p and r then e(9);
if p and not q then e(10);
if not p or not q then e(11);
if (p and r) or (q and r) then e(12);
if p and q and r then e(13);
if (p or q) = r then e(14);
end;
procedure tst2204;
{ Characters, Subranges, Enumerated types using intermediate level vars }
begin t:=2204; pct := pct + 1;
if 'q' <> kew then e(1);
c1 := 'a'; c2 := 'b'; c3 := 'a';
if c1 = c2 then e(2);
if c1 <> c3 then e(3);
sr1:=1939; sr2:=1945; sr3:=1939;
if sr1=sr2 then e(4);
if sr1<>sr3 then e(5);
color := orange; hue := green; tint := orange;
if color = hue then e(6);
if color <> tint then e(7);
end;
procedure tst2205;
{ Intermediate level arrays }
var i,l,o:integer;
begin t:=2205; pct := pct + 1;
for i:= -10 to 10 do a1[i] := i*i;
if (a1[-10]<>100) or (a1[9]<>81) then e(1);
#ifndef NOFLOAT
for i:=1939 to 1945 do a2[i]:=i-1938.5;
if (abs(a2[1939]-0.5) > eps) or (abs(a2[1945]-6.5) > eps) then e(2);
#endif
color := orange;
a3[green] := true; a3[orange] := true;
if (a3[green]<>true) or (a3[orange]<>true) then e(3);
a3[green] := false; a3[orange] := false;
if (a3[green]<>false) or (a3[orange]<>false) then e(4);
a4[mouse]:='m'; a4[house]:='h';
if (a4[mouse] <> 'm') or (a4[house]<>'h' ) then e(5);
for i:=1939 to 1945 do a5[51,bat,false,i]:=300+i;
if a5[51,bat,false,1940] <> 2240 then e(6);
for i:=50 to 52 do a5[i,cat,true,1943]:=200+i;
if (a5[50,cat,true,1943] <> 250) or (a5[52,cat,true,1943] <> 252) then e(7);
for i:= -10 to 10 do a1[i]:= 0;
for i:= 0 to 10 do a1[i div 2 + i div 2]:= i+1;
if(a1[0]<>2) or (a1[5]<>0) or (a1[8]<>10) then e(8);
for i:= 0 to 10 do
for l:= 0 to 3 do
for o:= 0 to 3 do
if ( (i+l+o) div 2) * 2 = i+l+o then a6[i,l,o]:='e' else a6[i,l,o]:='o';
if (a6[2,2,2]<>'e') or (a6[2,2,3]<>'o') or (a6[0,3,1]<>'e') then e(9);
end;
#ifndef NOFLOAT
procedure tst2206;
{ Intermediate level records }
begin t:=2206; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true; r1.x:=3.0;
c1:='a'; i:=0; j:=0; p:=false; x:=100.0;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) or (r1.x<>3.0) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) or (r2.x<>3.0) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1; x:=r1.x;
if (c1<>'x') or (i<>40) or (p<>true) or (x<>3.0) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true; r3.x:=3.0;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) or (r3.x<>3.0) then e(4);
end;
#else
procedure tst2206;
{ Intermediate level records }
begin t:=2206; pct := pct + 1;
r1.c1:='x'; r1.i:=40; r1.j:=50; r1.p:=true;
c1:='a'; i:=0; j:=0; p:=false;
if (r1.c1<>'x') or (r1.i<>40) or (r1.p<>true) then e(1);
r2:=r1;
if (r2.c1<>'x') or (r2.i<>40) or (r2.p<>true) then e(2);
i:=r1.i; p:=r1.p; c1:=r1.c1;
if (c1<>'x') or (i<>40) or (p<>true) then e(3);
r3.c1:='x'; r3.i:=40; r3.j:=50; r3.p:=true;
if (r3.c1<>'x') or (r3.i<>40) or (r3.p<>true) then e(4);
end;
#endif
procedure tst2207;
{ Intermediate level sets }
begin t:=2207; pct := pct + 1;
colors := [];
colors := colors + [];
if colors <> [] then e(1);
colors := colors + [pink];
if colors <> [pink] then e(2);
colors := colors + [green];
if colors <> [pink,green] then e(3);
if colors <> [green,pink] then e(4);
colors := colors - [pink];
if colors <> [green] then e(5);
beasts := [chicken] + [chicken,pig];
if beasts <> [pig,chicken] then e(6);
beasts := [] - [farmersdaughter];
if beasts <> [] then e(7);
bits := [0] + [1] - [0];
if bits <> [1] then e(8);
end;
procedure tst2208;
{ Pointers }
begin t:=2208; pct := pct + 1;
new(p1); new(p2); new(p3); new(p4);
p1^ := 1066;
if p1^ <> 1066 then e(1);
p2^.i := 1215;
if p2^.i <> 1215 then e(2);
p3^[0]:= 1566;
if p3^[0] <> 1566 then e(3);
p4^ := [pink];
if p4^ <> [pink] then e(4);
end;
procedure tst2209;
var i:integer;
begin t:=2209; pct := pct + 1;
head := nil;
for i:= 1 to 100 do
begin new(tail); tail^.val:=100+i; tail^.next :=head; head:= tail end;
if (tail^.val<>200) or (tail^.next^.val<>199) then e(1);
if tail^.next^.next^.next^.next^.next^.next^.next^.next^.val<> 192 then e(2);
tail^.next^.next^.next^.val := 30;
if tail^.next^.next^.next^.val <> 30 then e(3);
end;
begin t:=22; pct:=pct+1;
#ifndef NOFLOAT
tst2201; tst2202; tst2203; tst2204; tst2205; tst2206;
#else
tst2201; tst2203; tst2204; tst2205; tst2206;
#endif
tst2207; tst2208; tst2209;
end;
{************************************************************************}
procedure tst25;
{ Statement sequencing }
label 0,1,2,3;
procedure tst2501;
begin t:=2501;
goto 0;
e(1);
end;
begin t:=25; pct:=pct+1;
tst2501;
e(1);
0:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
i:=0;
1: if i>10 then goto 3 else goto 2;
e(2);
2: i:=i+1; goto 1;
e(3);
3:
end;
{************************************************************************}
procedure tst26;
{ More data structures }
type x = array[1..5] of integer;
ta = array [1..5] of array [1..5] of x;
tb = array [1..5] of record p1: ^x; p2: ^x end;
tr = record c: record b: record a: integer end end end ;
var low,i,j,k:integer; a:ta; b:tb; r:tr; hi:integer;
procedure tst2601(w:ta; x:tb; y:tr);
var i,j,k: integer;
begin t:=2601; pct:=pct+1;
for i:= 1 to 5 do for j:= 1 to 5 do for k:=1 to 5 do
if w[i][j][k] <> i*i + 7*j + k then e(1);
if (x[1].p1^[1] <> -9) or (x[2].p2^[4]<> -39) then e(2);
if y.c.b.a <> 102 then e(3);
end;
begin t:=26; pct:=pct+1;
low := 1000; hi := 1001;
for i:= 1 to 5 do for j:=1 to 5 do for k:= 1 to 5 do a[i][j][k] :=i*i+7*j+k;
new(b[1].p1); new(b[2].p2);
b[1].p1^[1] := -9; b[2].p2^[4] := -39;
r.c.b.a := 102;
tst2601(a,b,r);
t:=26;
if(low <> 1000) or (hi <> 1001) then e(1);
end;
{************************************************************************}
procedure tst27;
{ Assignments }
begin t:=27; pct := pct+1;
i:=3; j:=2; k:= -100;
l:= 1+(i*(j+(i*(j+(i*(j+(i*(3+j*(i*1+j*2)))))))));
if l <> 1456 then e(1);
l:= ((((((((((((((((((((((((((((((((0))))))))))))))))))))))))))))))));
if l <> 0 then e(2);
l:=(((i*j)+(3*i)-5) div 10)*(((i*j)+(3*i)-5) div 10)*(((i*j)+(3*i)-5) div 10)
+ (((i*j)+(3*i)-5) div 10)*(((i*j)+(3*i)-5) div 10)*(((i*j)+(3*i)-5) div 10);
if l <> 2 then e(3);
l:=((j+j) div 4) * ((j+j) div 4) * ((j+j) div 4)* (j div 3 + j div 4 + 3)+
((j+j) div 4) * ((j+j) div 4) * ((j+j) div 4)* (j div 3 + j div 4 + 3);
if l <> 6 then e(4);
i:=j*j*j*j*j*j*j*j*j*j*j*j*j*j - 16383;
if i <>1 then e(5);
l:=(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i+(i))))))))))))))));
if l <> 16 then e(6);
l:= (((((((((((((((((j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j)+j);
if l <> 34 then e(7);
l:= (-(-(-(-(-(-(-(-(-(j))))))))));
if l <> -2 then e(8);
#ifndef NOFLOAT
x:= 0.1; y:=0.2; z:=0.3;
w:=(((((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0))*
((((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0))*
((((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0))*
((((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0))*
((((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)+(((x+y)/z)*2.0)))-1;
if abs(w-32767) > 0.0001 then e(9);
i:= trunc(100*y+0.5); if i <> 20 then e(10);
i:= 32767; w:=i; if w <> 32767 then e(11);
#endif
end;
{************************************************************************}
procedure tst28;
{ Calls }
var i:integer;
function ack(m,n:integer):integer;
begin if m=0
then ack := n+1
else if n=0
then ack := ack(m-1,1)
else ack := ack(m-1,ack(m,n-1))
end;
procedure fib(a:integer; var b:integer); { Fibonacci nrs }
var i,j:integer;
begin
if (a=1) or (a=2) then b:=1 else
begin fib(a-1,i); fib(a-2,j); b:=i+j end
end;
begin t:=28; pct:= pct+1;
if ack(2,2) <> 7 then e(1);
if ack(3,3) <> 61 then e(2);
if ack(3,5) <> 253 then e(3);
if ack(2,100) <> 203 then e(4);
fib(10,i); if i <> 55 then e(5);
fib(20,i); if i <> 6765 then e(6);
end;
{************************************************************************}
procedure tst29;
{ Loops }
var i,l:integer; p:boolean;
begin t:= 29; pct:=pct+1;
j:=5;
k:=0; for i:=1 to j do k:=k+1; if k<>5 then e(1);
k:=0; for i:=5 to j do k:=k+1; if k<>1 then e(2);
k:=0; for i:=6 to j do k:=k+1; if k<>0 then e(3);
k:=0; for i:=-1 downto -j do k:=k+1; if k<>5 then e(4);
k:=0; for i:=-5 downto -j do k:=k+1; if k<>1 then e(5);
k:=0; for i:=-6 downto j do k:=k+1; if k<>0 then e(6);
k:=0; for i:=1 downto 10 do k:=k+1; if k<>0 then e(7);
k:=0; for l:=1 to j do k:=k+1; if k<>5 then e(8);
k:=0; for l:=5 to j do k:=k+1; if k<>1 then e(9);
k:=0; for l:=6 to j do k:=k+1; if k<>0 then e(10);
k:=0; for l:=-1 downto -j do k:=k+1; if k<>5 then e(11);
k:=0; for l:=-5 downto -j do k:=k+1; if k<>1 then e(12);
k:=0; for l:=-6 downto j do k:=k+1; if k<>0 then e(13);
k:=0; for l:=1 downto 10 do k:=k+1; if k<>0 then e(14);
k:=0; for p:= true downto false do k:=k+1; if k<>2 then e(15);
k:=0; for p:= false to true do k:=k+1; if k<>2 then e(16);
k:=0; while k<0 do k:=k+1; if k<>0 then e(17);
k:=0; repeat k:=k+1; until k>0; if k<> 1 then e(18);
k:=0; repeat k:=k+1; until k > 15; if k <> 16 then e(18);
k:=0; while k<=10 do k:=k+1; if k<> 11 then e(19);
end;
{************************************************************************}
procedure tst30;
{ case statements }
begin t:=30; pct:=pct+1;
i:=3; k:=0;
case i*i-7 of
0: k:=0; 1: k:=0; 2: k:=1; 3,4: k:=0
end;
if k<>1 then e(1);
color := red; k:=0;
case color of
red: k:=1; blue: k:=0; yellow: k:=0
end;
if k<>1 then e(2);
k:=0;
case color of
red,blue: k:=1; yellow: k:=0
end;
if k<>1 then e(3);
end;
#ifndef NOFLOAT
{************************************************************************}
procedure tst31;
{ with statements }
var ra: record i:integer; x:real; p:tp2; q:single;
a2: record a3: tp2 end
end;
rb: record j: integer; y:real; pp:tp2; qq:single end;
begin t:=31; pct:=pct+1;
i:=0; x:=0;
ra.i:=-3006; ra.x:=-6000.23; ra.q[0]:=35; ra.p.i:=20;
with ra do
begin if (i<>-3006) or (x<>-6000.23) or (q[0]<>35)
or (p.i<>20) then e(2);
i:=300; x:= 200.5; q[0]:=35; p.i:=-10
end;
if (ra.i<>300) or (ra.x<>200.5) or (ra.q[0]<>35) or (ra.p.i<>-10) then e(3);
with ra.p do if i <> -10 then e(4);
i:= -23;
ra.a2.a3.i := -909;
with ra do if a2.a3.i <> -909 then e(5);
with ra.a2 do if a3.i <> -909 then e(6);
with ra.a2.a3 do if i <> -909 then e(7);
with ra.a2 do i:=5;
if (i<>5) or (ra.a2.a3.i <> -909) then e(8);
with ra.a2.a3 do i:= 6;
if i<>5 then e(9);
if ra.a2.a3.i <> 6 then e(10);
with ra,rb do
begin x:=3.5; y:=6.5; i:=3; j:=9 end;
if (ra.x<>3.5) or (rb.y<>6.5) or (ra.i<>3) or (rb.j<>9) then e(11);
end;
#else
{************************************************************************}
procedure tst31;
{ with statements }
var ra: record i:integer; p:tp2; q:single;
a2: record a3: tp2 end
end;
rb: record j: integer; pp:tp2; qq:single end;
begin t:=31; pct:=pct+1;
#ifndef NOFLOAT
i:=0; x:=0;
#else
i:=0;
#endif
ra.i:=-3006; ra.q[0]:=35; ra.p.i:=20;
with ra do
begin if (i<>-3006) or (q[0]<>35)
or (p.i<>20) then e(2);
i:=300; q[0]:=35; p.i:=-10
end;
if (ra.i<>300) or (ra.q[0]<>35) or (ra.p.i<>-10) then e(3);
with ra.p do if i <> -10 then e(4);
i:= -23;
ra.a2.a3.i := -909;
with ra do if a2.a3.i <> -909 then e(5);
with ra.a2 do if a3.i <> -909 then e(6);
with ra.a2.a3 do if i <> -909 then e(7);
with ra.a2 do i:=5;
if (i<>5) or (ra.a2.a3.i <> -909) then e(8);
with ra.a2.a3 do i:= 6;
if i<>5 then e(9);
if ra.a2.a3.i <> 6 then e(10);
with ra,rb do
begin i:=3; j:=9 end;
if (ra.i<>3) or (rb.j<>9) then e(11);
end;
#endif
{************************************************************************}
procedure tst32;
{ Standard procedures }
begin t:=32; pct:=pct+1;
if abs(-1) <> 1 then e(1);
i:= -5; if abs(i) <> 5 then e(2);
#ifndef NOFLOAT
x:=-2.0; if abs(x) <> 2.0 then e(3);
#endif
if odd(5) = false then e(4);
if odd(4) then e(5);
if sqr(i) <> 25 then e(6);
if succ(i) <> -4 then e(7);
if succ(red) <> blue then e(8);
if pred(blue) <> red then e(9);
if ord(red) <> 0 then e(10);
if ord(succ(succ(red))) <> 2 then e(11);
if chr(ord(chr(ord(chr(ord('u')))))) <> 'u' then e(12);
if ord(chr(ord(chr(ord(chr(50)))))) <> 50 then e(13);
#ifndef NOFLOAT
if abs(trunc(5.2)-5.0) > eps then e(14);
if abs(sin(3.1415926536)) > 10*eps then e(15);
if abs(exp(1.0)-2.7182818) > 0.0001 then e(16);
if abs(ln(exp(1.0))- 1.0) > 3*eps then e(17);
if abs(sqrt(25.0)-5.0) > eps then e(18);
if abs(arctan(1.0) - 3.1415926535/4.0) > 0.0001 then e(19);
if abs(ln(arctan(1)*4) - 1.144729886) > 0.000001 then e(20);
if abs(sin(1) - 0.841470985 ) > 0.000001 then e(21);
if abs(cos(1) - 0.540302306) > 0.000001 then e(22);
if abs(sqrt(2) - 1.4142135623) > 0.000001 then e(23);
if abs(sqrt(10) - 3.1622776601) > 0.000001 then e(24);
if abs(sqrt(1000.0) - 31.622776602) > 0.00001 then e(25);
#endif
end;
{***************************************************************************}
procedure tst33;
{ Functions }
var i,j,k,l,m: integer;
begin t:=33; pct := pct+1;
i:=1; j:=2; k:=3; l:=4; m:=10;
if twice(k) <> m-l then e(1);
if twice(1) <> 2 then e(2);
if twice(k+1) <> twice(l) then e(3);
if twice(twice(twice(inc(twice(inc(3)))))) <> 72 then e(4);
if twice(inc(j+twice(inc(twice(i+1+inc(k)+inc(k))+twice(2)))))<>106
then e(5);
if twice(1) + twice(2) * twice(3) <> 26 then e(6);
if 3 <> 0 + twice(1) + 1 then e(7);
if 0 <> 0 * twice(m) then e(8);
end;
{**********************************************************************}
{ Main Program }
begin ect := 0; pct := 0;
tst21; tst22; tst25; tst26; tst27; tst28; tst29; tst30; tst31; tst32; tst33;
write('Program t2:',pct:3,' tests completed.');
writeln('Number of errors = ',ect:0);
end.

333
lang/pc/test/t3.p
View File

@@ -1,333 +0,0 @@
{
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
This product is part of the Amsterdam Compiler Kit.
Permission to use, sell, duplicate or disclose this software must be
obtained in writing. Requests for such permissions may be sent to
Dr. Andrew S. Tanenbaum
Wiskundig Seminarium
Vrije Universiteit
Postbox 7161
1007 MC Amsterdam
The Netherlands
}
{$i64 : sets of integers contain 64 bits}
program t3(input,output,f1,f2,f3,f4,f5,f6);
{ The Berkeley and EM-1 compilers both can handle this program }
const rcsversion='$Header$';
type wavelength = (red,blue,yellow,q1,q2,q3,q4,q5,q6,q7,q8,q9,q10,q11,
pink,green,orange);
spectrum= set of wavelength;
bit = 0..1;
tp3= packed record c1:char; i:integer; p:boolean; x:real end;
tp4= record c1:char; i:integer; p:boolean; x:real end;
vec1 = array [-10..+10] of integer;
vrec = record case t:boolean of false:(r:real); true:(b:bit) end;
var t,pct,ect:integer;
i,j,k,l:integer;
x,y: real;
p:boolean;
c2:char;
a1: vec1;
c: array [1..20] of char;
r3: tp3;
r4: tp4;
vr: vrec;
colors: spectrum;
letters,cset:set of char;
f1: text;
f2: file of spectrum;
f3: file of tp3;
f4: file of tp4;
f5: file of vec1;
f6: file of vrec;
procedure e(n:integer);
begin
ect := ect + 1;
writeln(' Error', n:3,' in test ', t)
end;
{************************************************************************}
procedure tst34;
{ Global files }
var i:integer; c1:char;
begin t:=34; pct := pct + 1;
rewrite(f1);
if not eof(f1) then e(1);
write(f1,'abc',20+7:2,'a':2); writeln(f1);
write(f1,'xyz');
i:=-3000; write(f1,i:5);
reset(f1);
if eof(f1) or eoln(f1) then e(2);
for i:=1 to 17 do read(f1,c[i]);
if(c[1]<>'a') or (c[3]<>'c') or (c[5]<>'7') or (c[8]<>' ') or
(c[12]<>'-') or (c[13]<>'3') or (c[16]<>'0') then e(3);
if not eof(f1) then e(4);
rewrite(f1);
for i:= 32 to 127 do write(f1,chr(i));
reset(f1); p:= false;
for i:= 32 to 127 do begin read(f1,c1); if ord(c1) <> i then p:=true end;
if p then e(5);
rewrite(f1);
for c1 := 'a' to 'z' do write(f1,c1);
reset(f1); p:= false;
for c1 := 'a' to 'z' do begin read(f1,c2); if c2 <> c1 then p:=true end;
if p then e(6);
end;
procedure tst36;
var i,j:integer;
begin t:=36; pct:=pct+1;
rewrite(f2); rewrite(f3); rewrite(f4); rewrite(f5); rewrite(f6);
colors := []; f2^ := colors; put(f2);
colors := [red]; f2^ := colors; put(f2);
colors := [red,blue]; f2^ := colors; put(f2);
colors := [yellow,blue]; f2^ := colors; put(f2);
reset(f2);
colors := f2^; get(f2); if colors <> [] then e(4);
colors := f2^; get(f2); if colors <> [red] then e(5);
colors := f2^; get(f2); if colors <> [blue,red] then e(6);
colors := f2^; get(f2); if colors <> [blue,yellow] then e(7);
r3.c1:='w'; r3.i:= -100; r3.x:=303.56; r3.p:=true; f3^:=r3; put(f3);
r3.c1:='y'; r3.i:= -35; r3.x:=26.32; f3^:=r3; put(f3);
r3.c1:='q'; r3.i:= +29; r3.x:=10.00; f3^:=r3; put(f3);
r3.c1:='j'; r3.i:= 8; r3.x:=10000; f3^:=r3; put(f3);
for i:= 1 to 1000 do begin f3^ := r3; put(f3) end;
reset(f3);
r3 := f3^; get(f3);
if (r3.c1<>'w') or (r3.i<>-100) or (r3.x<>303.56) then e(8);
r3 := f3^; get(f3);
if (r3.c1<>'y') or (r3.i<> -35) or (r3.x<> 26.32) then e(9);
r3 := f3^; get(f3);
if (r3.c1<>'q') or (r3.i<> 29) or (r3.x<> 10.00) then e(10);
r3 := f3^; get(f3);
if (r3.c1<>'j') or (r3.i<> 8) or (r3.x<> 10000) then e(11);
r4.c1:='w'; r4.i:= -100; r4.x:=303.56; r4.p:=true; f4^:=r4; put(f4);
r4.c1:='y'; r4.i:= -35; r4.x:=26.32; f4^:=r4; put(f4);
r4.c1:='q'; r4.i:= +29; r4.x:=10.00; f4^:=r4; put(f4);
r4.c1:='j'; r4.i:= 8; r4.x:=10000; f4^:=r4; put(f4);
for i:= 1 to 1000 do begin f4^ := r4; put(f4) end;
reset(f4);
r4 := f4^; get(f4);
if (r4.c1<>'w') or (r4.i<>-100) or (r4.x<>303.56) then e(12);
r4 := f4^; get(f4);
if (r4.c1<>'y') or (r4.i<> -35) or (r4.x<> 26.32) then e(13);
r4 := f4^; get(f4);
if (r4.c1<>'q') or (r4.i<> 29) or (r4.x<> 10.00) then e(13);
r4 := f4^; get(f4);
if (r4.c1<>'j') or (r4.i<> 8) or (r4.x<> 10000) then e(14);
for j:= 1 to 100 do
begin for i:= -10 to +10 do a1[i] := i*j; f5^ := a1; put(f5); end;
reset(f5);
for j:= 1 to 99 do
begin a1:=f5^; get(f5); for i:= -10 to +10 do if a1[i]<> i*j then e(14) end;
vr.t:=false;
for i:= 1 to 1000 do begin vr.r:=i+0.5; f6^:=vr; put(f6) ; p:=true; end;
reset(f6); p:=false;
for i:= 1 to 999 do
begin vr:=f6^; get(f6); if vr.r <> i+0.5 then p:=true end;
if p then e(15);
rewrite(f6);
if not eof(f6) then e(16);
for i:= 1 to 1000 do begin vr.b:=i mod 2; f6^:=vr; put(f6) end;
reset(f6);
if eof(f6) then e(17);
p:=false;
for i:= 1 to 1000 do
begin vr:=f6^; get(f6); if vr.b <> i mod 2 then p:=true end;
if not eof(f6) then e(18);
if p then e(19);
rewrite(f1);
f1^:=chr(10);
put(f1);
reset(f1);
if ord(f1^) <> 32 then e(20);
rewrite(f1);
x:=0.0625; write(f1,x:6:4, x:6:2);
reset(f1); read(f1,y); if y <> 0.0625 then e(21);
reset(f1); for i:= 1 to 12 do begin c[i]:= f1^; get(f1) end;
if (c[1]<>'0') or (c[2]<>'.') or (c[4]<>'6') then e(22);
if (c[7]<>' ') or (c[9]<>'0') or (c[10]<>'.') or (c[12]<>'6') then e(23);
end;
{************************************************************************}
procedure tst35;
{ Local files }
var g1: text;
g2: file of spectrum;
g3: file of tp4;
g4: file of vec1;
i,j:integer;
begin t:=35; pct := pct + 1;
rewrite(g1); rewrite(g2); rewrite(g3); rewrite(g4);
if (not (eof(g1) and eof(g4))) then e(1);
writeln(g1,'abc', 20+7:2,'a':2);
write(g1,'xyz');
reset(g1);
if eof(g1) or eoln(g1) then e(2);
read(g1,c[1]); read(g1,c[2]); read(g1,c[3],c[4],c[5],c[6],c[7]);
if (c[1]<>'a') or (c[3]<>'c') or (c[4]<>'2') or (c[7]<>'a') then e(3);
if not eoln(g1) then e(4)
else readln(g1);
for i:=1 to 2 do read(g1,c[8+i]);
if c[10]<>'y' then e(5);
if eof(g1) or eoln(g1) then e(6);
colors := []; g2^ := colors; put(g2);
colors := [pink]; g2^ := colors; put(g2);
colors := [pink,green]; g2^ := colors; put(g2);
colors := [orange,green]; g2^ := colors; put(g2);
reset(g2);
colors := g2^; get(g2); if colors <> [] then e(7);
colors := g2^; get(g2); if colors <> [pink] then e(8);
colors := g2^; get(g2); if colors <> [green,pink] then e(9);
colors := g2^; get(g2); if colors <> [green,orange] then e(10);
r4.c1:='w'; r4.i:= -100; r4.x:=303.56; g3^:=r4; put(g3);
r4.c1:='y'; r4.i:= -35; r4.x:=26.32; g3^:=r4; put(g3);
r4.c1:='q'; r4.i:= +29; r4.x:=10.00; g3^:=r4; put(g3);
r4.c1:='j'; r4.i:= 8; r4.x:=10000; g3^:=r4; put(g3);
for i:= 1 to 1000 do begin g3^ := r4; put(g3) end;
reset(g3);
if eof(g3) then e(11);
r4 := g3^; get(g3);
if (r4.c1<>'w') or (r4.i<>-100) or (r4.x<>303.56) then e(12);
r4 := g3^; get(g3);
if (r4.c1<>'y') or (r4.i<> -35) or (r4.x<> 26.32) then e(13);
r4 := g3^; get(g3);
if (r4.c1<>'q') or (r4.i<> 29) or (r4.x<> 10.00) then e(14);
r4 := g3^; get(g3);
if (r4.c1<>'j') or (r4.i<> 8) or (r4.x<> 10000) then e(15);
for j:= 1 to 100 do
begin for i:= -10 to +10 do a1[i] := i*j; g4^ := a1; put(g4) end;
reset(g4);
for j:= 1 to 100 do
begin a1:=g4^; get(g4); for i:= -10 to +10 do if a1[i]<>i*j then e(16) end;
if not eof(g2) then e(17);
colors:=[q1,q2,q3,q4,q5,q6,q7,q8,q9,q10,q11];
end;
{***********************************************************************}
procedure tst37;
{ Intermediate level files }
var g1: text;
g2: file of spectrum;
g3: file of tp4;
g4: file of vec1;
procedure tst3701;
var i,j:integer;
begin t:=3701; pct := pct + 1;
rewrite(g1); rewrite(g2); rewrite(g3); rewrite(g4);
if (not (eof(g1) and eof(g4))) then e(1);
writeln(g1,'abc', 20+7:2,'a':2);
write(g1,'xyz');
reset(g1);
if eof(g1) or eoln(g1) then e(2);
read(g1,c[1]); read(g1,c[2]); read(g1,c[3],c[4],c[5],c[6],c[7]);
if (c[1]<>'a') or (c[3]<>'c') or (c[4]<>'2') or (c[7]<>'a') then e(3);
if not eoln(g1) then e(4)
else readln(g1);
for i:=1 to 2 do read(g1,c[8+i]);
if c[10]<>'y' then e(5);
if eof(g1) or eoln(g1) then e(6);
colors := []; g2^ := colors; put(g2);
colors := [pink]; g2^ := colors; put(g2);
colors := [pink,green]; g2^ := colors; put(g2);
colors := [orange,green]; g2^ := colors; put(g2);
reset(g2);
colors := g2^; get(g2); if colors <> [] then e(7);
colors := g2^; get(g2); if colors <> [pink] then e(8);
colors := g2^; get(g2); if colors <> [green,pink] then e(9);
colors := g2^; get(g2); if colors <> [green,orange] then e(10);
r4.c1:='w'; r4.i:= -100; r4.x:=303.56; g3^:=r4; put(g3);
r4.c1:='y'; r4.i:= -35; r4.x:=26.32; g3^:=r4; put(g3);
r4.c1:='q'; r4.i:= +29; r4.x:=10.00; g3^:=r4; put(g3);
r4.c1:='j'; r4.i:= 8; r4.x:=10000; g3^:=r4; put(g3);
for i:= 1 to 1000 do begin g3^ := r4; put(g3) end;
reset(g3);
if eof(g3) then e(11);
r4 := g3^; get(g3);
if (r4.c1<>'w') or (r4.i<>-100) or (r4.x<>303.56) then e(12);
r4 := g3^; get(g3);
if (r4.c1<>'y') or (r4.i<> -35) or (r4.x<> 26.32) then e(13);
r4 := g3^; get(g3);
if (r4.c1<>'q') or (r4.i<> 29) or (r4.x<> 10.00) then e(14);
r4 := g3^; get(g3);
if (r4.c1<>'j') or (r4.i<> 8) or (r4.x<> 10000) then e(15);
for j:= 1 to 100 do
begin for i:= -10 to +10 do a1[i] := i*j; g4^ := a1; put(g4) end;
reset(g4);
for j:= 1 to 100 do
begin a1:=g4^; get(g4); for i:= -10 to +10 do if a1[i]<>i*j then e(16) end;
end;
begin t:=37; pct := pct+1;
tst3701;
t:=37;
if not eof(g2) then e(1);
end;
{***********************************************************************}
procedure tst38;
{ Advanced set theory }
begin t:=38; pct := pct + 1;
if [50] >= [49,51] then e(1);
if [10] <= [9,11] then e(2);
if not ([50] <= [49..51]) then e(3);
i:=1; j:=2; k:=3; l:=5;
if [i] + [j] <> [i,j] then e(4);
if [i] + [j] <> [i..j] then e(5);
if [j..i] <> [] then e(6);
if [j..l] + [j..k] <> [2,3,4,5] then e(7);
if ([1..k, l..8] + [10]) * [k..7, 2, l] <> [2,3,l..7] then e(8);
if [i..9] - [j..l] <> [1,l+1..k*k] then e(9);
if [k..j] <> [i..j] * [k..l] then e(10);
if not ([k..10] <= [i..15]) then e(11);
if not ([k-1..k*l] <= [i..15]) then e(12);
letters := ['a','b', 'z'];
if letters <> ['a', 'b', 'z'] then e(13);
cset := ['a'] + ['b', 'c', 'z'] - ['c','d'];
if cset <> letters then e(14);
cset := ['a'..'e'];
if cset <> ['a', 'b', 'c', 'd', 'e'] then e(15);
cset := ['a'..'z', '0'..'9', '+','-','*','/','.',':','(',')','{','}'];
if not ('+' in cset) or not ('.' in cset) or not ('}' in cset) then e(16);
letters := ['a'..'z' , '0'..'9'];
if letters >= cset then e(17);
end;
{***********************************************************************}
{ Main program }
begin ect:=0; pct:=0;
tst34; tst35; tst36; tst37; tst38;
write('Program t3:',pct:3,' tests completed.');
writeln('Number of errors = ',ect:0);
end.

411
lang/pc/test/t4.p
View File

@@ -1,411 +0,0 @@
#
{
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
This product is part of the Amsterdam Compiler Kit.
Permission to use, sell, duplicate or disclose this software must be
obtained in writing. Requests for such permissions may be sent to
Dr. Andrew S. Tanenbaum
Wiskundig Seminarium
Vrije Universiteit
Postbox 7161
1007 MC Amsterdam
The Netherlands
}
program t4(input,output);
{ Tests for the EM-1 compiler }
const rcsversion='$Header$';
type vec = array[1..1000] of integer;
spectrum = set of (red,blue,yellow);
#ifndef NOFLOAT
tp2 = record c1:char;i,j:integer; p:boolean; x:real end;
#else
tp2 = record c1:char;i,j:integer; p:boolean end;
#endif
cmat = array[0..3,0..7] of ^spectrum;
single = array [0..0] of integer;
np = ^node;
node = record val: integer; next: np end;
var t,ect,pct:integer;
r1: tp2;
pt1,pt2: ^vec;
pt3:^integer;
mk: ^integer;
i,j: integer;
procedure e(n:integer);
begin
ect := ect + 1;
writeln(' Error', n:3,' in test ', t)
end;
function inc(k:integer):integer; begin inc := k+1 end;
function twice(k:integer):integer; begin twice := 2*k end;
function decr(k:integer):integer; begin decr := k-1 end;
procedure tst40;
{ Mark and Release }
var i:integer;
procedure grab;
var i:integer;
begin
for i:=1 to 10 do new(pt1);
for i:=1 to 1000 do new(pt3);
end;
begin t:= 40; pct:=pct+1;
for i:=1 to 10 do
begin
mark(mk);
new(pt2);
grab;
release(mk)
end;
end;
procedure tst41;
{ Empty sets }
begin t:=41; pct := pct + 1;
if red in [] then e(1);
if ([] <> []) then e(2);
if not ([] = []) then e(3);
if not([] <=[]) then e(4);
if not ( [] >= []) then e(5);
end;
{************************************************************************}
procedure tst42;
{ Record variants. These tests are machine dependent }
var s:record b:boolean; case t:boolean of false:(c:char);true:(d:cmat) end;
w: packed record
case z:boolean of
false: (x:array[0..20] of integer);
true: (a,b,c,d,e,f,g,h,i,j,k,l:char)
end;
y: record
case z:boolean of
false: (x:array[0..20] of integer);
true: (a,b,c,d,e,f,g,h,i,j,k,l:char)
end;
i:integer;
begin t:=42; pct:=pct+1;
s.t:=false; s.c:='x'; if s.c <> 'x' then e(1);
for i:=0 to 20 do begin w.x[i]:=-1; y.x[i]:=-1 end;
w.a:=chr(0); w.f:=chr(0);
y.a:=chr(0); y.f:=chr(0);
if (ord(w.a) <> 0) or (ord(w.b) <> 255) then e(3);
if (ord(w.c) <> 255) or (ord(w.d)<>255) then e(4);
if (ord(w.e) <> 255) or (ord(w.f) <> 0) then e(5);
if ord(y.a) <> 0 then e(6);
if ord(y.f) <> 0 then e(7);
end;
{************************************************************************}
procedure tst43;
{ Procedure and function parameters }
function incr(k:integer):integer; begin incr := k+1 end;
function double(k:integer):integer; begin double := 2*k end;
function eval(function f(a:integer):integer; a:integer):integer;
begin eval:=f(a) end;
function apply(function f(a:integer):integer; a:integer):integer;
begin apply:=eval(f,a) end;
procedure x1(function f(a:integer):integer; a:integer; var r:integer);
procedure x2(function g(c:integer):integer; b:integer; var s:integer);
begin s:=apply(g,b); end;
begin x2(f, a+a, r) end;
procedure p0(procedure p(x:integer); i,j:integer);
begin
if j=0 then p(i) else p0(p,i+j,j-1)
end;
procedure p1(a,b,c,d:integer);
var k:integer;
procedure p2(x:integer);
begin k:= x*x end;
begin k:=0;
p0(p2,a,b);
if k <> c then e(d);
end;
begin t:=43; pct := pct+1;
i:=10; j:=20;
if incr(0) <> 1 then e(1);
if decr(i) <> 9 then e(2);
if double(i+j) <> 60 then e(3);
if incr(double(j)) <> 41 then e(4);
if decr(double(incr(double(i)))) <> 41 then e(5);
if incr(incr(incr(incr(incr(5))))) <> 10 then e(6);
if eval(incr,i) <> 11 then e(7);
if eval(decr,3) <> 2 then e(8);
if incr(eval(double,15)) <> 31 then e(9);
if apply(incr,3) <> 4 then e(10);
x1(double,i,j); if j <> 40 then e(11);
x1(incr,i+3,j); if j <> 27 then e(12);
p1(3,5,324,13);
p1(10,4,400,14);
p1(1,8,1369,15);
j:=1;
if inc(incr(twice(double(inc(incr(twice(double(j)))))))) <> 26 then e(13);
end;
{************************************************************************}
procedure tst44;
{ Value parameters }
type ww2 = array[-10..+10] of tp2;
arra = array[-10..+10] of integer;
reca = record k:single; s:spectrum end;
pa = np;
#ifndef NOFLOAT
var l1:integer; xr:real; xb:boolean; xc:char; xar:cmat; xnode:pa;
#else
var l1:integer; xb:boolean; xc:char; xar:cmat; xnode:pa;
#endif
vec1: arra; vec2: ww2;
s2:spectrum; rec1: reca;
zero:0..0;
#ifndef NOFLOAT
procedure tst4401(pl1:integer; pxr:real; pxb:boolean; pxc:char;
#else
procedure tst4401(pl1:integer; pxb:boolean; pxc:char;
#endif
pxar:cmat; pxnode:pa; pxtp2:tp2;
pvec1:arra; pvec2:ww2; prec1:reca;
ps1,ps2:spectrum; psin:single; i,j:integer);
begin t:=4401; pct:=pct+1;
if pl1<>29 then e(1);
#ifndef NOFLOAT
if pxr<>-0.31 then e(2);
#endif
if pxb <> false then e(3);
if pxc <> 'k' then e(4);
if (pxar[1,1]^<>[red,blue]) or (pxar[2,2]^ <> [yellow]) then e(5);
if (pxnode^.val <> 105) or (pxnode^.next^.val <> 106) then e(6);
#ifndef NOFLOAT
if (pxtp2.c1 <> 'w') or (pxtp2.x <> 20.3) then e(7);
#else
if (pxtp2.c1 <> 'w') then e(7);
#endif
if pvec1[10] <> -996 then e(8);
#ifndef NOFLOAT
if pvec2[zero].x <> -300 then e(9);
#endif
if (prec1.k[zero] <> -421) or (prec1.s <> []) then e(10);
if (ps1<>[]) or (ps2<>[red]) then e(11);
if psin[zero] <> -421 then e(12);
if i <> -421 then e(13);
if j <> 106 then e(14);
pl1:=0; pxc:=' '; pxb:=true;
pxar[1,1]^:=[]; pxar[2,2]^:=[];
pxnode^.val:=0; pxnode^.next^.val:=1;
pxtp2.c1:=' ';
pvec1[10]:=0;
#ifndef NOFLOAT
pvec2[zero].x:=0;
#endif
prec1.k[zero]:=0;
psin[0]:=0; i:=0; j:=0;
end;
begin t:=44; pct:=pct+1;
zero:=0;
#ifndef NOFLOAT
l1:=29; xr:=-0.31; xb:=false; xc:='k';
#else
l1:=29; xb:=false; xc:='k';
#endif
new(xar[1,1]); xar[1,1]^ := [red,blue];
new(xar[2,2]); xar[2,2]^ := [yellow];
new(xar[1,2]); xar[1,2]^ := [yellow];
new(xnode); xnode^.val :=105;
new(xnode^.next); xnode^.next^.val :=106;
#ifndef NOFLOAT
r1.c1:='w'; r1.x:=20.3;
vec1[10] := -996; vec2[zero].x := -300;
#else
r1.c1:='w';
vec1[10] := -996;
#endif
rec1.k[zero]:=-421; rec1.s :=[];
s2:=[red];
#ifndef NOFLOAT
tst4401(l1, xr, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
#else
tst4401(l1, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
#endif
[], s2, rec1.k, rec1.k[zero], xnode^.next^.val);;
t:=44;
if l1<>29 then e(1);
#ifndef NOFLOAT
if xr<> -0.31 then e(2);
#endif
if xb <> false then e(3);
if xc <> 'k' then e(4);
if (xar[1,1]^ <> []) or (xar[2,2]^ <> []) then e(5);
if xar[1,2]^ <> [yellow] then e(6);
if (xnode^.val <> 0) or (xnode^.next^.val <> 1) then e(7);
#ifndef NOFLOAT
if (r1.c1 <> 'w') or (r1.x <> 20.3) then e(8);
#else
if (r1.c1 <> 'w') then e(8);
#endif
if vec1[10] <> -996 then e(9);
#ifndef NOFLOAT
if vec2[zero].x <> -300 then e(10);
#endif
if (rec1.k[zero] <> -421) or (rec1.s <> []) then e(11);
if s2 <> [red] then e(12);
end;
{************************************************************************}
procedure tst45;
{ Var parameters }
type ww2 = array[-10..+10] of tp2;
arra = array[-10..+10] of integer;
reca = record k:single; s:spectrum end;
pa = np;
#ifndef NOFLOAT
var l1:integer; xr:real; xb:boolean; xc:char; xar:cmat; xnode:pa;
#else
var l1:integer; xb:boolean; xc:char; xar:cmat; xnode:pa;
#endif
vec1: arra; vec2: ww2;
s1,s2:spectrum; rec1: reca;
zero:0..0;
#ifndef NOFLOAT
procedure tst4501(var pl1:integer; var pxr:real; var pxb:boolean; var pxc:char;
#else
procedure tst4501(var pl1:integer; var pxb:boolean; var pxc:char;
#endif
var pxar:cmat; var pxnode:pa; var pxtp2:tp2;
var pvec1:arra; var pvec2:ww2; var prec1:reca;
var ps1,ps2:spectrum; var psin:single; var i,j:integer);
begin t:=4501; pct:=pct+1;
if pl1<>29 then e(1);
#ifndef NOFLOAT
if pxr<>-0.31 then e(2);
#endif
if pxb <> false then e(3);
if pxc <> 'k' then e(4);
if (pxar[1,1]^<>[red,blue]) or (pxar[2,2]^ <> [yellow]) then e(5);
if (pxnode^.val <> 105) or (pxnode^.next^.val <> 106) then e(6);
#ifndef NOFLOAT
if (pxtp2.c1 <> 'w') or (pxtp2.x <> 20.3) then e(7);
#else
if (pxtp2.c1 <> 'w') then e(7);
#endif
if pvec1[10] <> -996 then e(8);
#ifndef NOFLOAT
if pvec2[zero].x <> -300 then e(9);
#endif
if (prec1.k[zero] <> -421) or (prec1.s <> []) then e(10);
if (ps1<>[]) or (ps2<>[red]) then e(11);
if psin[zero] <> -421 then e(12);
if i <> -421 then e(13);
if j <> 106 then e(14);
#ifndef NOFLOAT
pl1:=0; pxr:=0; pxc:=' '; pxb:=true;
#else
pl1:=0; pxc:=' '; pxb:=true;
#endif
pxar[1,1]^:=[]; pxar[2,2]^:=[];
pxnode^.val:=0; pxnode^.next^.val:=1;
pxtp2.c1:=' ';
#ifndef NOFLOAT
pxtp2.x := 0;
#endif
pvec1[10]:=0;
#ifndef NOFLOAT
pvec2[zero].x:=0;
#endif
prec1.k[zero]:=0;
psin[0]:=0; i:=223; j:=445;
end;
begin t:=45; pct:=pct+1;
zero:=0;
#ifndef NOFLOAT
l1:=29; xr:=-0.31; xb:=false; xc:='k';
#else
l1:=29; xb:=false; xc:='k';
#endif
new(xar[1,1]); xar[1,1]^ := [red,blue];
new(xar[2,2]); xar[2,2]^ := [yellow];
new(xar[1,2]); xar[1,2]^ := [yellow];
new(xnode); xnode^.val :=105;
new(xnode^.next); xnode^.next^.val :=106;
#ifndef NOFLOAT
r1.c1:='w'; r1.x:=20.3;
vec1[10] := -996; vec2[zero].x := -300;
#else
r1.c1:='w';
vec1[10] := -996;
#endif
rec1.k[zero]:=-421; rec1.s :=[];
s1:=[]; s2:=[red];
#ifndef NOFLOAT
tst4501(l1, xr, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
#else
tst4501(l1, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
#endif
s1, s2, rec1.k, rec1.k[zero], xnode^.next^.val);;
t:=45;
if l1<>0 then e(1);
#ifndef NOFLOAT
if xr<> 0 then e(2);
#endif
if xb <> true then e(3);
if xc <> ' ' then e(4);
if (xar[1,1]^ <> []) or (xar[2,2]^ <> []) then e(5);
if xar[1,2]^ <> [yellow] then e(6);
if (xnode^.val <> 0) or (xnode^.next^.val <> 445) then e(7);
#ifndef NOFLOAT
if (r1.c1 <> ' ') or (r1.x <> 0) then e(8);
#else
if (r1.c1 <> ' ') then e(8);
#endif
if vec1[10] <> 0 then e(9);
#ifndef NOFLOAT
if vec2[zero].x <> 0 then e(10);
#endif
if (rec1.k[zero] <> 223) or (rec1.s <> []) then e(11);
if (s1 <> []) or (s2 <> [red]) then e(12);
end;
begin ect:=0; pct:=0;
tst40; tst41; tst42; tst43; tst44; tst45;
write('Program t4:',pct:3,' tests completed.');
writeln('Number of errors = ',ect:0);
end.

13
lang/pc/test/t5.p
View File

@@ -1,13 +0,0 @@
{$i1000}
program test(output);
const rcsversion='$Header$';
var b:false..true;
i:integer;
s:set of 0..999;
begin
b:=true; if not b then writeln('error 1');
s:=[0,100,200,300,400,500,600,700,800,900];
for i:=0 to 999 do
if (i in s) <> (i mod 100=0) then
writeln('error 2');
end.

66
lang/pc/test/tstenc.p
View File

@@ -1,66 +0,0 @@
{
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
This product is part of the Amsterdam Compiler Kit.
Permission to use, sell, duplicate or disclose this software must be
obtained in writing. Requests for such permissions may be sent to
Dr. Andrew S. Tanenbaum
Wiskundig Seminarium
Vrije Universiteit
Postbox 7161
1007 MC Amsterdam
The Netherlands
}
program tstenc(output);
const rcsversion='$Header$';
trapno=150;
var level:integer;
beenhere:boolean;
e:integer;
procedure trap(erno:integer); extern;
procedure encaps(procedure p;procedure q(erno:integer)); extern;
procedure p1;
label 1;
var plevel:integer;
procedure p2;
var plevel:integer;
begin plevel:=3 ; trap(trapno) ;
writeln('executing unreachable code in p2') ; e:=e+1 ;
end;
procedure q2(no:integer);
var qlevel:integer;
begin qlevel:=-3 ;
if no<>trapno then
begin writeln('wrong trapno ',no,' in q2'); e:=e+1 end ;
if plevel<>2 then
begin writeln('wrong level ',plevel,' in q2'); e:=e+1 end ;
trap(trapno) ;
goto 1;
writeln('executing unreachable code in q2') ; e:=e+1 ;
end;
begin plevel:=2 ; encaps(p2,q2) ;
writeln('executing unreachable code in p1'); e:=e+1;
1: if plevel<>2 then
begin writeln('wrong level ', plevel, 'in p1') ; e:=e+1 end ;
beenhere:=true ;
end; { body of p1 }
procedure q1(no:integer);
var qlevel:integer;
begin qlevel:=-2 ;
if no<>trapno then
begin writeln('wrong trapno ',no,' in q1'); e:=e+1 end ;
if level<>1 then
begin writeln('wrong level ',level,' in q1'); e:=e+1 end ;
end;
begin
level:=1 ;
e:=0 ;
beenhere:=false ;
encaps(p1,q1);
if not beenhere then
begin writeln('illegaly skipped code in p1') ; e:=e+1 end;
if e=0 then writeln('encaps OK')
end.

75
lang/pc/test/tstgto.p
View File

@@ -1,75 +0,0 @@
program tstgto(output);
type int=integer;
pint=^integer;
var ga0,ga1,ga2,ga3,ga4,ga5:int;
gp0,gp1,gp2,gp3,gp4,gp5:pint;
procedure level0(a1,a2:int;p1,p2:pint);
label 1;
var a3,a4,a5:int;p3,p4,p5:pint;
procedure level1(a1,a2:int;p1,p2:pint);
var a3,a4,a5:int;p3,p4,p5:pint;
procedure level2(a1,a2:int;p1,p2:pint);
var a3,a4,a5:int;p3,p4,p5:pint;
begin
a1:= -5;a2:=a1;a3:=a2;a4:=a3;a5:=a4;
a1:= -4;a2:=a1;a3:=a2;a4:=a3;
a1:= -3;a2:=a1;a3:=a2;
a1:= -2;a2:=a1;
a1:=a5+a5;a1:= -1;
p1:=gp0;p2:=p1;p3:=p2;p4:=p3;p5:=p4;
p1:=gp1;p2:=p1;p3:=p2;p4:=p3;
p1:=gp2;p2:=p1;p3:=p2;
p1:=gp3;p2:=p1;
p1:=p5;p1:=gp4;
goto 1;
end; { level 2 }
begin
a1:=ga4;a2:=a1;a3:=a2;a4:=a3;a5:=a4;
a1:=ga3;a2:=a1;a3:=a2;a4:=a3;
a1:=ga2;a2:=a1;a3:=a2;
a1:=ga1;a2:=a1;
a1:=ga0;
p1:=gp4;p2:=p1;p3:=p2;p4:=p3;p5:=p4;
p1:=gp3;p2:=p1;p3:=p2;p4:=p3;
p1:=gp2;p2:=p1;p3:=p2;
p1:=gp1;p2:=p1;
p1:=gp0;
level2(a5,a4,p5,p4);
writeln('Error, goto failed');
end; { level 1 }
begin
a1:=ga5;a2:=a1;a3:=a2;a4:=a3;a5:=a4;
a1:=ga4;a2:=a1;a3:=a2;a4:=a3;
a1:=ga3;a2:=a1;a3:=a2;
a1:=ga2;a2:=a1;
a1:=ga1;
p1:=gp5;p2:=p1;p3:=p2;p4:=p3;p5:=p4;
p1:=gp4;p2:=p1;p3:=p2;p4:=p3;
p1:=gp3;p2:=p1;p3:=p2;
p1:=gp2;p2:=p1;
p1:=gp1;
level1(a5,a4,p5,p4);
writeln('Error, goto failed');
1:
if (a1 <> ga1) then writeln('level0:a1 has wrong value');
if (a2 <> ga2) then writeln('level0:a2 has wrong value');
if (a3 <> ga3) then writeln('level0:a3 has wrong value');
if (a4 <> ga4) then writeln('level0:a4 has wrong value');
if (a5 <> ga5) then writeln('level0:a5 has wrong value');
if (p1 <> gp1) then writeln('level0:p1 has wrong value');
if (p2 <> gp2) then writeln('level0:p2 has wrong value');
if (p3 <> gp3) then writeln('level0:p3 has wrong value');
if (p4 <> gp4) then writeln('level0:p4 has wrong value');
if (p5 <> gp5) then writeln('level0:p5 has wrong value');
end; { level 0 }
begin
ga0:=0;ga1:=1;ga2:=2;ga3:=3;ga4:=4;ga5:=5;
new(gp0);new(gp1);new(gp2);new(gp3);new(gp4);new(gp5);
level0(ga5,ga4,gp5,gp4);
end.