d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Initial revision

Browse source
This commit is contained in:
ceriel 1988-10-04 13:41:01 +00:00
parent a66faf4100
commit e1b871a6ea
126 changed files with 11223 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

127
lang/a68s/liba68s/.distr Normal file
View file

@ -0,0 +1,127 @@
LIST
Makefile
aclose.c
aopen.c
arctan.c
associate.p
bytespack.p
calls.e
catpl.p
cfstr.p
chains.e
cleanup.c
collp.p
colltm.p
collts.p
complex.p
cos.c
crmult.p
crrefn.p
dclpsn.p
div.e
drefm.p
drefs.p
dumbacch.p
duminch.p
dummy.p
dumoutch.p
e.h
ensure.p
entier.c
errorr.p
exit.c
exp.c
fixed.p
float.p
genrec.p
get.e
getaddr.e
getmult.p
getout.p
gett.p
global.p
globale.e
gtot.p
gtotref.p
gvasstx.p
gvscope.p
heapmul.p
heapstr.p
hoist.e
is.p
linit2.p
linit34.p
linitinc.p
ln.c
lpb.s
make
maxr.c
mod.c
mulis.p
nassp.p
nassts.p
newline.p
onend.p
openclose.p
pcollmul.p
pcollst.p
posenq.p
powi.c
powneg.p
powr.c
put.e
putt.p
random.p
rangent.p
rangext.p
reset.p
rnstart.p
routn.p
routnp.p
rowm.p
rownm.p
run68g.p
rundecs.p
safeaccess.p
scopext.p
selectr.p
selecttsn.p
setcc.p
sett.p
shl.c
shr.c
signi.c
signr.c
sin.c
skip.p
slice12.p
slicen.p
space.p
sqrt.c
standass.p
standback.e
standin.p
standout.p
stbacch.p
stinch.p
stopen.p
stoutch.p
strsubtrim.p
structscope.p
swap.e
tassp.p
tasstm.p
tassts.p
temp.c
time.c
timesten.c
trace.e
trig.p
trim.p
uplwb.p
uplwbm.p
uplwbmstr.p
whole.p
widchar.p
widen.p
wrs.e

119
lang/a68s/liba68s/LIST Normal file
View file

@ -0,0 +1,119 @@
/user/t63/em/lib/sun3/tail_a68stail_a68s.a
errorr.p
global.p
safeaccess.p
collp.p
colltm.p
collts.p
complex.p
crmult.p
crrefn.p
dclpsn.p
drefm.p
drefs.p
dummy.p
genrec.p
getmult.p
getout.p
gtot.p
gtotref.p
gvasstx.p
gvscope.p
heapmul.p
heapstr.p
is.p
linit2.p
linit34.p
linitinc.p
nassts.p
nassp.p
pcollmul.p
pcollst.p
rangent.p
rangext.p
rnstart.p
routn.p
routnp.p
rowm.p
rownm.p
scopext.p
selectr.p
selecttsn.p
setcc.p
skip.p
slice12.p
slicen.p
strsubtrim.p
structscope.p
tassp.p
tasstm.p
tassts.p
trim.p
widchar.p
widen.p
catpl.p
cfstr.p
mulis.p
powneg.p
uplwb.p
uplwbm.p
uplwbmstr.p
bytespack.p
random.p
trig.p
associate.p
dumbacch.p
duminch.p
dumoutch.p
ensure.p
fixed.p
float.p
gett.p
newline.p
onend.p
openclose.p
posenq.p
putt.p
reset.p
sett.p
space.p
standass.p
standin.p
standout.p
stbacch.p
stinch.p
stopen.p
stoutch.p
whole.p
calls.e
chains.e
div.e
get.e
getaddr.e
globale.e
hoist.e
put.e
standback.e
swap.e
trace.e
wrs.e
aclose.c
aopen.c
powi.c
powr.c
mod.c
entier.c
signi.c
signr.c
timesten.c
shl.c
shr.c
time.c
sin.c
cos.c
arctan.c
sqrt.c
exp.c
ln.c
maxr.c
cleanup.c

130
lang/a68s/liba68s/Makefile Normal file
View file

@ -0,0 +1,130 @@
EMROOT=../../..
ACK=$(EMROOT)/bin/$(MACH)
PC=$(ACK) -.p -PR$(EMROOT)/lang/a68s/cpem/cpem
PCFLAGS=-v -L -e -LIB -Oego -SR -CJ -BO -SP
EPCFLAGS=-v -L -e -LIB $(BSD4) $(VAX4)
UTIL=$(EMROOT)/lang/a68s/util
TAILOR=$(UTIL)/tailor
XREF=$(UTIL)/xref -i$(UTIL)/pascal.ign -p
CHECKSEQ=$(UTIL)/checkseq
TERRS=/dev/tty
TNOS=101 2 103 104 105 111 21 122 123 124 125 32 41 150 151 152 153 154 155 161 $(RECIPE)
CFILES=aclose.c aopen.c powi.c powr.c mod.c entier.c signi.c signr.c \
timesten.c shl.c shr.c time.c sin.c cos.c arctan.c sqrt.c exp.c \
ln.c maxr.c cleanup.c
COFILES=aclose.o aopen.o powi.o powr.o mod.o entier.o signi.o signr.o \
timesten.o shl.o shr.o time.o sin.o cos.o arctan.o sqrt.o exp.o \
ln.o maxr.o cleanup.o
FILES=run68g.p
GFILES=errorr.p global.p safeaccess.p
GOFILES=errorr.o global.o safeaccess.o
PFILES=collp.p colltm.p collts.p complex.p crmult.p crrefn.p dclpsn.p drefm.p \
drefs.p dummy.p genrec.p getmult.p getout.p gtot.p gtotref.p \
gvasstx.p gvscope.p heapmul.p heapstr.p is.p linit2.p linit34.p \
linitinc.p nassts.p nassp.p pcollmul.p pcollst.p rangent.p rangext.p \
rnstart.p routn.p routnp.p rowm.p rownm.p scopext.p selectr.p \
selecttsn.p setcc.p skip.p slice12.p slicen.p strsubtrim.p \
structscope.p tassp.p tasstm.p tassts.p trim.p widchar.p widen.p
POFILES=collp.o colltm.o collts.o complex.o crmult.o crrefn.o dclpsn.o drefm.o \
drefs.o dummy.o genrec.o getmult.o getout.o gtot.o gtotref.o gvasstx.o \
gvscope.o heapmul.o heapstr.o is.o linit2.o linit34.o linitinc.o \
nassts.o nassp.o pcollmul.o pcollst.o rangent.o rangext.o rnstart.o \
routn.o routnp.o rowm.o rownm.o scopext.o selectr.o selecttsn.o \
setcc.o skip.o slice12.o slicen.o strsubtrim.o structscope.o tassp.o \
tasstm.o tassts.o trim.o widchar.o widen.o
OPFILES=catpl.p cfstr.p mulis.p powneg.p uplwb.p uplwbm.p uplwbmstr.p
OPOFILES=catpl.o cfstr.o mulis.o powneg.o uplwb.o uplwbm.o uplwbmstr.o
SPFILES=bytespack.p random.p trig.p
SPOFILES=bytespack.o random.o trig.o
TFILES=associate.p dumbacch.p duminch.p dumoutch.p ensure.p fixed.p float.p \
gett.p newline.p onend.p openclose.p posenq.p putt.p reset.p sett.p \
space.p standass.p standin.p standout.p stbacch.p stinch.p stopen.p \
stoutch.p whole.p
TOFILES=associate.o dumbacch.o duminch.o dumoutch.o ensure.o fixed.o float.o \
gett.o newline.o onend.o openclose.o posenq.o putt.o reset.o sett.o \
space.o standass.o standin.o standout.o stbacch.o stinch.o stopen.o \
stoutch.o whole.o
EFILES=calls.e chains.e div.e get.e getaddr.e globale.e hoist.e put.e \
standback.e swap.e trace.e wrs.e
EOFILES=calls.o chains.o div.o get.o getaddr.o globale.o hoist.o put.o \
standback.o swap.o trace.o wrs.o
LIBFILES=$(GFILES) $(PFILES) $(OPFILES) $(SPFILES) $(TFILES)
LIBOFILES=$(GOFILES) $(POFILES) $(OPOFILES) $(SPOFILES) $(TOFILES)
all: liba68s$(w)$(p)
rundecs.h: check$(w)$(p) rundecs.p
echo $(TNOS) 300 | $(TAILOR) rundecs.p $(TERRS) \
>rundecs.h
rundecsg.h: check$(w)$(p) rundecs.p
echo $(TNOS) 71 300 | $(TAILOR) rundecs.p $(TERRS) >rundecsg.h
run68g.o: rundecsg.h run68g.p
(cat rundecsg.h; \
cat run68g.p ) \
>temp.p
$(PC) $(PCFLAGS) -c.s temp.p
sed -e '/^.define _m_a_i_n/d' -e '/^.extern _m_a_i_n/,$$d' -e '/^.globl _m_a_i_n/,$$d' temp.s > run68g.s
$(PC) $(PCFLAGS) -c.o run68g.s
rm temp.p run68g.s
.p.o:
( echo $(TNOS) 300 | $(TAILOR) $*.p $(TERRS) ) \
>temp.p
$(PC) $(PCFLAGS) -c.s temp.p
mv temp.s $*.s
$(PC) $(PCFLAGS) -c.o $*.s
rm temp.p $*.s
$(LIBOFILES): rundecs.h
.SUFFIXES: .e
e.h: check$(w)$(p)
.e.o:
$(PC) $(EPCFLAGS) -c.s -DEM_WSIZE=$(w) -DEM_PSIZE=$(p) $*.e
$(PC) $(EPCFLAGS) -c.o $*.s
rm $*.s
$(EOFILES): e.h
maxr.o: maxr.c
/lib/cpp <maxr.c >temp.c
$(PC) $(PCFLAGS) -I$(EMROOT)/h -c.s -o maxr.s temp.c
$(PC) $(PCFLAGS) -c.o maxr.s
rm maxr.s
.c.o:
$(PC) $(PCFLAGS) -I$(EMROOT)/h -c.s $*.c
$(PC) $(PCFLAGS) -c.o $*.s
rm $*.s
liba68s: liba68s$(w)$(p)
liba68s$(w)$(p): $(EOFILES) $(COFILES) $(LIBOFILES) $(SOFILES) run68g.o
-rm liba68s$(w)$(p)
$(ASAR) crv liba68s$(w)$(p) $(EOFILES) $(COFILES) $(LIBOFILES) $(SOFILES) run68g.o
sh -c '$${RANLIB-:} liba68s$(w)$(p)'
check$(w)$(p):
/bin/make clean
echo >> check$(w)$(p)
checkseq:
$(CHECKSEQ) rundecs.p $(LIBFILES)
pr:
pr rundecs.p $(LIBFILES) $(FILES) $(EFILES) $(CFILES)
xref:
(/bin/make pr; \
echo 1000 | $(TAILOR) rundecs.p $(TERRS) | $(XREF) | pr -h rundecs.xref; \
for II in $(LIBFILES); do echo 1000 | $(TAILOR) $$II $(TERRS); done \
| $(XREF) | pr -h run68.xref \
) | opr
clean:
-rm liba68s$(w)$(p) check?? rundec*.h *.o

15
lang/a68s/liba68s/aclose.c Normal file
View file

@ -0,0 +1,15 @@
#include <pc_file.h>
extern _cls(); /* pc runtime routine to close a file */
/* as the following routine is called from a pascal subroutine */
/* and the pascal compiler has been fixed to alwayd supply static links */
/* to non-global externals the parameter 'statlink' is a dummy to fill */
/* the space occupied by the static link. The parameter is first instead */
/* of last because of the C method of passing its parameters backwards */
ACLS(statlink,f) int *statlink; struct file *f; {
_cls(f);
}

46
lang/a68s/liba68s/aopen.c Normal file
View file

@ -0,0 +1,46 @@
#include <pc_file.h>
#include <pc_err.h>
#define BUFFLENGTH 512 /* number of items in buffer */
extern struct file *_curfil; /* for error mesages from trap */
extern _trp(); /* pc runtime trap routine */
extern creat(); /* unix open for write */
extern open(); /* unix open for read */
static int initfile (desc,f) int desc; struct file *f; {
_curfil=f;
if ( (desc & 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 = BUFFLENGTH;
f->size = 1;
f->ptr = f->bufadr;
f->flags = desc;
return(1);
}
/* as both the following routines are called from a pascal subroutine */
/* and the pascal compiler has been fixed to alwayd supply static links */
/* to non-global externals the parameter 'statlink' is a dummy to fill */
/* the space occupied by the static link. The parameter is first instead */
/* of last because of the C method of passing its parameters backwards */
AOPN(statlink,f) int *statlink; struct file *f; {
if ( initfile ((int)(MAGIC|TXTBIT),f) )
f->count=0;
}
ACRE(statlink,f) int *statlink; struct file *f; {
if ( initfile ((int)(WRBIT|EOFBIT|ELNBIT|MAGIC|TXTBIT),f) )
f->count=f->buflen;
}

4
lang/a68s/liba68s/arctan.c Normal file
View file

@ -0,0 +1,4 @@
extern double _atn();
double ARCTAN(statlink, x)
int *statlink; double x;
{return(_atn(x));}

89
lang/a68s/liba68s/associate.p Normal file
View file

@ -0,0 +1,89 @@
70000 #include "rundecs.h"
70010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
70020 (**)
70030 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
70040 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
70050 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
70060 PROCEDURE PCINCR (STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN ;
70070 (**)
70080 (**)
70090 (*+01() (*$X6*) ()+01*)
70100 FUNCTION PROC( PROCEDURE P (*-01() ( COV: OBJECTP ; EFET: FETROOMP ) ()-01*) ): ASPROC ; EXTERN ;
70110 (*-01()
70120 FUNCTION PROC1(
70130 PROCEDURE P( COV: OBJECTP ; CHARS: GETBUFTYPE ; TERM: TERMSET ; I: INTEGER ; EFET: FETROOMP )
70140 ): ASPROC ; EXTERN ;
70150 FUNCTION PROC2( PROCEDURE P( COV, STRNG: OBJECTP ; LB, UB: INTEGER ; EFET: FETROOMP ) ): ASPROC ; EXTERN ;
70160 FUNCTION PROC3( PROCEDURE P( COV: OBJECTP ; P, L, C: INTEGER ; EFET: FETROOMP ) ): ASPROC ; EXTERN ;
70170 FUNCTION PROCH( PROCEDURE P( COV: OBJECTP ; L: LFNTYPE ) ): ASPROC ; EXTERN ;
70180 ()-01*)
70190 PROCEDURE ASSWRSTR(COV, PUTSTRING: OBJECTP; LB, UB: INTEGER; EFET: FETROOMP); EXTERN;
70200 PROCEDURE ASSRDSTR(COV:OBJECTP; CHARS:GETBUFTYPE; TERM(*+01(),TERM1()+01*): TERMSET; I: INTEGER; EFET: FETROOMP);
70210 EXTERN;
70220 PROCEDURE ASSNEWLINE(COV: OBJECTP; EFET: FETROOMP); EXTERN;
70230 PROCEDURE ASSNEWPAGE(COV: OBJECTP; EFET: FETROOMP); EXTERN;
70240 PROCEDURE ASSRESET(COV: OBJECTP; EFET: FETROOMP); EXTERN;
70250 PROCEDURE ASSSET(COV: OBJECTP; P, L, C: INTEGER; EFET: FETROOMP); EXTERN;
70260 (**)
70270 (**)
70280 FUNCTION ASSOCIATE(RF,CHARFILE:OBJECTP): INTEGER;
70290 VAR CB,OFF,CPS:INTEGER;
70300 F,PCOV:OBJECTP;
70310 BEGIN
70320 F := INCPTR(SAFEACCESS(RF), -STRUCTCONST);
70330 PCINCR(INCPTR(F, STRUCTCONST),FILEBLOCK,-INCRF);
70340 ENEW(PCOV, COVERSIZE);
70350 (*-02() PCOV^.FIRSTWORD := SORTSHIFT * ORD(COVER) + INCRF; ()-02*)
70360 (*+02() PCOV^.PCOUNT:=1; PCOV^.SORT:=COVER; ()+02*)
70370 F^.PCOVER:=PCOV;
70380 WITH CHARFILE^ DO
70390 WITH DESCVEC[0] DO
70400 BEGIN CPS:=DI-LBADJ;
70410 CB:=UI;
70420 OFF:=DI;
70430 IF LI<>1 THEN ERRORR(WRONGMULT);
70440 END;
70450 WITH PCOV^ DO
70460 BEGIN COFCPOS:=1; LOFCPOS:=1; POFCPOS:=1;
70470 CHARBOUND:=CB; LINEBOUND:=1; PAGEBOUND:=1;
70480 STATUS:=[OPENED,CHARMOOD];
70490 POSSIBLES:=[GETPOSS,PUTPOSS,RESETPOSS,SETPOSS,ASSPOSS];
70500 DOPUTS := PROC(*-01()2()-01*)(ASSWRSTR);
70510 DOGETS := PROC(*-01()1()-01*)(ASSRDSTR);
70520 DONEWLINE := PROC(ASSNEWLINE);
70530 DONEWPAGE := PROC(ASSNEWPAGE);
70540 DORESET := PROC(ASSRESET);
70550 DOSET := PROC(*-01()3()-01*)(ASSSET);
70560 ASSOC := TRUE;
70570 ASSREF:=CHARFILE;
70580 CPOSELS:=CPS;
70590 OFFSETDI:=OFF;
70600 FPINC(CHARFILE^);
70610 OSCOPE := CHARFILE^.OSCOPE;
70620 END;
70630 WITH F^ DO
70640 BEGIN
70650 IF RF^.OSCOPE<PCOV^.OSCOPE THEN ERRORR(RSCOPE);
70660 LOGICALFILEMENDED:=UNDEFIN;
70670 PHYSICALFILEMENDED:=UNDEFIN;
70680 PAGEMENDED:=UNDEFIN;
70690 LINEMENDED:=UNDEFIN;
70700 TERM:=[];
70710 (*+01() TERM1:=[] ; ()+01*)
70720 END;
70730 IF FPTST(RF^) THEN GARBAGE(RF);
70740 ASSOCIATE := ORD(NOT(OPENED IN PCOV^.STATUS));
70750 END; (*ASSOCIATE*)
70760 (**)
70770 (**)
70780 (*+01() (*$X4*) ()+01*)
70790 (**)
70800 (**)
70810 (*-02()
70820 BEGIN (*OF A68*)
70830 END; (*OF A68*)
70840 ()-02*)
70850 (*+01()
70860 BEGIN (*OF MAIN PROGRAM*)
70870 END (* OF EVERYTHING *).
70880 ()+01*)

24
lang/a68s/liba68s/bytespack.p Normal file
View file

@ -0,0 +1,24 @@
65000 #include "rundecs.h"
65010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
65020 (**)
65030 (**)
65040 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
65050 (**)
65060 (**)
65070 FUNCTION BYTESPACK(STRING :OBJECTP): A68INT;
65080 (*BYTESPACK*)
65090 VAR PTR: UNDRESSP;
65100 BEGIN WITH STRING^ DO
65110 IF STRLENGTH > CHARPERWORD THEN ERRORR(RBYTESPACK)
65120 ELSE BEGIN
65130 PTR := INCPTR(STRING, STRINGCONST);
65140 BYTESPACK := PTR^.FIRSTINT;
65150 END
65160 END;
65170 (**)
65180 (**)
65190 (*-02() BEGIN END ; ()-02*)
65200 (*+01()
65210 BEGIN (*OF MAIN PROGRAM*)
65220 END (*OF EVERYTHING*).
65230 ()+01*)

132
lang/a68s/liba68s/calls.e Normal file
View file

@ -0,0 +1,132 @@
#include "e.h"
exa .1 ; global Pascal variables
exp $PROC
exp $PROC1
exp $PROC2
exp $PROC3
exp $PROCH
exp $CLPASC1
exp $CLPASC2
exp $CLPASC5
exp $CLRDSTR
exp $CL68
exp $FUNC68
exp $CALLPASC
pro $PROC,0
LFL SZADDR+SZADDR ; load environment, static link for procedure
LFL SZADDR ; load address of code
ret SZPROC
end 0
pro $PROC1,0
LFL SZADDR+SZADDR
LFL SZADDR
ret SZPROC
end 0
pro $PROC2,0
LFL SZADDR+SZADDR
LFL SZADDR
ret SZPROC
end 0
pro $PROC3,0
LFL SZADDR+SZADDR
LFL SZADDR
ret SZPROC
end 0
pro $PROCH,0
LFL SZADDR+SZADDR
LFL SZADDR
ret SZPROC
end 0
pro $CLPASC1,SZWORD
loc PASCALSTAMP
stl -SZWORD
lal SZADDR ; load base address of params (source)
loc SZADDR+SZPROC
los SZWORD
cai
ret 0
end SZWORD
pro $CLPASC2,SZWORD
loc PASCALSTAMP
stl -SZWORD ; set frame stamp as pascal
lal SZADDR ; load base address of params (source)
loc SZADDR+SZADDR+SZPROC
los SZWORD
cai ; call proc, params & static link set
ret 0
end SZWORD
#define P5PARAMSPACE SZADDR+SZADDR+SZWORD+SZWORD+SZADDR+SZPROC
pro $CLPASC5,SZWORD
loc PASCALSTAMP
stl -SZWORD ; set frame stamp as pascal
lal SZADDR ; load base address of params (source)
loc P5PARAMSPACE
los SZWORD
cai
ret 0
end SZWORD
#define PRDSTRSPACE SZADDR+SZADDR+16+SZADDR+SZADDR+SZPROC
pro $CLRDSTR,SZWORD
loc PASCALSTAMP
stl -SZWORD ; set frame stamp as pascal
lal SZADDR ; load base address of params (source)
loc PRDSTRSPACE
los SZWORD
cai
ret 0
end SZWORD
pro $CL68,SZWORD
loc PASCALSTAMP
stl -SZWORD
LFL SZADDR ; OBJECTP parameter
LLC 0 ; bitpattern
loc 1 ; locrg
LFL SZADDR+SZADDR+SZADDR ; procbl
dup SZADDR
LFL SZADDR+SZADDR ; env
exg SZADDR
loi SZADDR ; XBASE
cai
ret 0
end SZWORD
pro $FUNC68,SZWORD
loc PASCALSTAMP
stl -SZWORD
LFL SZADDR ; OBJECTP parameter
LLC 0 ; bitpattern
loc 1 ; locrg
LFL SZADDR+SZADDR+SZADDR ; procbl
dup SZADDR
LFL SZADDR+SZADDR ; env
exg SZADDR
loi SZADDR ; XBASE
cai
ret SZWORD
end SZWORD
pro $CALLPASC,SZWORD ; +SZADDR+SZWORD
loc PASCALSTAMP
stl -SZWORD
lal SZADDR+SZADDR+SZWORD+SZLONG ; address of first (A68) parameter
loe .1+SZWORD+SZADDR ; PASCPARAMS
los SZWORD
lae .1+SZWORD+SZADDR+SZWORD ; address of PASCPROC
loi SZPROC ; PASCPROC
cai
ret 0
end SZWORD ; +SZADDR+SZWORD

100
lang/a68s/liba68s/catpl.p Normal file
View file

@ -0,0 +1,100 @@
60000 #include "rundecs.h"
60010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
60020 (**)
60030 (**)
60040 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
60050 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN;
60060 FUNCTION SAFEACCESS (LOCATION: OBJECTP) : UNDRESSP; EXTERN;
60070 (**)
60080 (**)
60090 FUNCTION CATCC(LCH, RCH: CHAR): OBJECTP;
60100 (*PCAT*)
60110 VAR POINT :OBJECTP;
60120 BEGIN
60130 POINT := CRSTRING(2);
60140 WITH POINT^ DO
60150 BEGIN CHARVEC[1] := LCH; CHARVEC[2] := RCH END;
60160 CATCC := POINT;
60170 END;
60180 (**)
60190 (**)
60200 FUNCTION CATSS(LEFT, RIGHT: OBJECTP): OBJECTP;
60210 (*PCAT-1*)
60220 VAR POINT: OBJECTP;
60230 I, D: INTEGER; C: CHAR;
60240 BEGIN
60250 WITH LEFT^ DO
60260 BEGIN D := STRLENGTH;
60270 IF
60280 ( PCOUNT = 0 )
60290 AND
60300 ( STRLENGTH+RIGHT^.STRLENGTH <= (STRLENGTH + CHARPERWORD - 1) DIV CHARPERWORD * CHARPERWORD ) THEN
60310 BEGIN POINT := LEFT; I := D+RIGHT^.STRLENGTH; POINT^.STRLENGTH := I END
60320 ELSE
60330 BEGIN POINT := CRSTRING(STRLENGTH+RIGHT^.STRLENGTH);
60340 FOR I := 1 TO STRLENGTH DO
60350 BEGIN C := CHARVEC[I]; POINT^.CHARVEC[I] := C END;
60360 IF FPTST(LEFT^) THEN GARBAGE(LEFT)
60370 END
60380 END;
60390 WITH RIGHT^ DO
60400 FOR I := 1 TO RIGHT^.STRLENGTH DO
60410 BEGIN C := CHARVEC[I]; POINT^.CHARVEC[I+D] := C END;
60420 IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
60430 CATSS := POINT;
60440 END;
60450 (**)
60460 (**)
60470 FUNCTION PLABSS(LEFT, RIGHT: OBJECTP): OBJECTP;
60480 (*PPLUSABCH, PPLUSABCH-1*)
60490 VAR TEMP: OBJECTP;
60500 PILPTR: UNDRESSP;
60510 BEGIN
60520 WITH LEFT^ DO
60530 IF SORT = REFN THEN
60540 BEGIN
60550 WITH PVALUE^ DO FDEC; (*SO THAT CATSS CAN POSSIBLY RE-USE IT*)
60560 PVALUE := CATSS(PVALUE, RIGHT);
60570 WITH PVALUE^ DO FINC
60580 END
60590 ELSE
60600 BEGIN
60610 PILPTR := SAFEACCESS(LEFT);
60620 TEMP := PILPTR^.FIRSTPTR;
60630 WITH TEMP^ DO FDEC; (*SO THAT CATSS CAN POSSIBLY RE-USE IT*)
60640 PILPTR^.FIRSTPTR := CATSS(TEMP, RIGHT);
60650 WITH PILPTR^.FIRSTPTR^ DO FINC
60660 END;
60670 PLABSS := LEFT;
60680 END;
60690 (**)
60700 (**)
60710 FUNCTION PLTOSS(LEFT, RIGHT: OBJECTP): OBJECTP;
60720 (*PPLUSTOCS, PPLUSTOCS-1*)
60730 VAR TEMP: OBJECTP;
60740 PILPTR: UNDRESSP;
60750 BEGIN
60760 WITH RIGHT^ DO
60770 IF SORT = REFN THEN
60780 BEGIN
60790 WITH PVALUE^ DO FDEC;
60800 PVALUE := CATSS(LEFT, PVALUE);
60810 WITH PVALUE^ DO FINC
60820 END
60830 ELSE
60840 BEGIN
60850 PILPTR := SAFEACCESS(RIGHT);
60860 TEMP := PILPTR^.FIRSTPTR;
60870 WITH TEMP^ DO FDEC;
60880 PILPTR^.FIRSTPTR := CATSS(LEFT, TEMP);
60890 WITH PILPTR^.FIRSTPTR^ DO FINC
60900 END;
60910 PLTOSS := RIGHT;
60920 END;
60930 (**)
60940 (**)
60950 (*-02() BEGIN END ; ()-02*)
60960 (*+01()
60970 BEGIN (*OF MAIN PROGRAM*)
60980 END (*OF EVERYTHING*).
60990 ()+01*)

42
lang/a68s/liba68s/cfstr.p Normal file
View file

@ -0,0 +1,42 @@
61000 #include "rundecs.h"
61010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
61020 (**)
61030 (**)
61040 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
61050 (**)
61060 (**)
61070 FUNCTION CFSTR(LEFT, RIGHT: OBJECTP; JOB :INTEGER): INTEGER;
61080 (*PLTCS-1, PLECS-1, PEQCS-1, PNECS-1, PGECS-1, PGTCS-1*)
61090 LABEL 9;
61100 VAR MINPTR, LSTRLENGTH, RSTRLENGTH: INTEGER;
61110 LPTR, RPTR: UNDRESSP;
61120 BEGIN
61130 LSTRLENGTH := LEFT^.STRLENGTH; RSTRLENGTH := RIGHT^.STRLENGTH;
61140 IF LSTRLENGTH < RSTRLENGTH THEN
61150 MINPTR := (LSTRLENGTH+CHARPERWORD-1) DIV CHARPERWORD * SZWORD
61160 ELSE
61170 MINPTR := (RSTRLENGTH+CHARPERWORD-1) DIV CHARPERWORD * SZWORD;
61180 LPTR := INCPTR(LEFT, STRINGCONST); RPTR := INCPTR(RIGHT, STRINGCONST);
61190 WHILE ORD(LPTR)<ORD(LEFT)+STRINGCONST+MINPTR DO
61200 BEGIN
61210 IF LPTR^.FIRSTWORD<>RPTR^.FIRSTWORD THEN
61220 BEGIN LSTRLENGTH := LPTR^.FIRSTWORD; RSTRLENGTH := RPTR^.FIRSTWORD; GOTO 9 END;
61230 LPTR := INCPTR(LPTR, SZWORD); RPTR := INCPTR(RPTR, SZWORD);
61240 END;
61250 9: CASE JOB OF
61260 0: CFSTR := -ORD(LSTRLENGTH<RSTRLENGTH);
61270 1: CFSTR := -ORD(LSTRLENGTH<=RSTRLENGTH);
61280 2: CFSTR := -ORD(LSTRLENGTH=RSTRLENGTH);
61290 3: CFSTR := -ORD(LSTRLENGTH<>RSTRLENGTH);
61300 4: CFSTR := -ORD(LSTRLENGTH>=RSTRLENGTH);
61310 5: CFSTR := -ORD(LSTRLENGTH>RSTRLENGTH);
61320 END;
61330 IF FPTST(LEFT^) THEN GARBAGE(LEFT); IF FPTST(RIGHT^) THEN GARBAGE(RIGHT)
61340 END;
61350 (**)
61360 (**)
61370 (*-02() BEGIN END ; ()-02*)
61380 (*+01()
61390 BEGIN (*OF MAIN PROGRAM*)
61400 END (*OF EVERYTHING*).
61410 ()+01*)

198
lang/a68s/liba68s/chains.e Normal file
View file

@ -0,0 +1,198 @@
#include "e.h"
exp $GETLINEN
exp $ME
exp $STATIC
exp $DYNAMIC
exp $ARGBASE
exp $SETMYSTA
exp $SETNSTAT
exp $ISA68
exp $ISPUT
exp $ISGET
exp $GETCALLE
; function getlineno :integer;
pro $GETLINEN,0 ; return line no from hol0
loe 0
ret SZWORD
end
pro $ME,0
lor 0 ; lb -> stack
dch ; caller's lb -> stack
ret SZADDR ; clb -> function result area
end 0
pro $STATIC,0
LFL SZADDR ; param (lb of caller) (after static link)
lpb ; ab of param
loi SZADDR ; static link of param
ret SZADDR
end 0
pro $DYNAMIC,0
LFL SZADDR ; param (lb of caller) (after static link)
dch ; follow dynamic chain, using lb of caller
ret SZADDR
end 0
pro $ARGBASE,0
LFL SZADDR ; param (somebody's lb)
lpb ; convert to somebody's ab
ret SZADDR
end 0
pro $SETMYSTA,0
LFL SZADDR ; place param on stack
lor 0 ; lb -> stack , for dch
dch ; caller's lb -> stack
lpb ; caller's ab
sti SZADDR ; store param in caller's static link
ret 0
end 0
#ifndef VAX4
pro $SETNSTAT,0 ; called from RNSTART of insert n extra levels in
; the static chain of A68 (i.e. RNSTART's caller);
; there is guaranteed to be enough vacant space at
; the top of the IB of A68
lor 0 ; my LB
dch ; RNSTART LB
adp SZADDR ; fictitious LB
; BUT THIS MAY NOT BE LEGAL EM. REVIEW WHEN
; RNSTART IS REWRITTEN.
dup SZADDR
lxa 2 ; A68 AB
loi SZADDR ; A68 static
exg SZADDR
lpb ; fictitious AB
sti SZADDR ; (fictitious AB) := A68 static
dup SZADDR
lxa 2 ; A68 AB
sti SZADDR ; (A68 AB) := fictitious LB
2
lol SZADDR ; n
loc 1
sbi SZWORD
dup SZWORD
stl SZADDR ; n := n-1
zeq *3
dup SZADDR
lpb ; fictitious AB
dup SZADDR
loi SZADDR
exg SZADDR
SFF SZADDR ; (fictitious AB + 1) := (fictitious AB)
adp SZADDR ; new fictitious LB
dup SZADDR
dup SZADDR
lpb ; new fictitious AB
SFF -SZADDR ; (new fictitious AB -l = old fictitious AB) :=
; new fictitious LB
bra *2 ; with the new fictitious LB on the stack
3
ret 0
end 0
#else
pro $SETNSTAT,SZWORD ; called from RNSTART of insert n extra levels in
; the static chain of A68 (i.e. RNSTART's caller);
; this version does not assume that the space between
; LB and AB is a constant. It calls itself recursively
; to create n activation records, whose static chains
; are linked as required. The last activation then
; copies the return status block of RNSTART over itself,
; so exiting from RNSTART but leaving the extra chains
; still within the stack.
lor 0 ; SLB
dch ; RLB
dup SZADDR ; RLB | RLB
dch ; RLB | ALB
lpb ; RLB | AAB
dup SZADDR ; RLB | AAB | AAB
loi SZADDR ; RLB | AAB | (AAB)
lor 0 ; RLB | AAB | (AAB) | SLB
dch ; RLB | AAB | (AAB) | RLB
lpb ; RLB | AAB | (AAB) | RAB
sti SZADDR ; RLB | AAB (RAB) := (AAB)
sti SZADDR ; (AAB) := RLB
; now my caller (RNSTART the first time) has been linked
; into the static chain of HIS caller.
lol SZADDR ; n
loc 1
sbi SZWORD ; n-1
dup SZWORD
zeq *4
lxl 1
cal $SETNSTAT
asp SZWORD+SZADDR ; but it should never return here
nop
4 ; now we must move the return status block of RNSTART
; on top of our own. We are still statically within RNSTART
LFL 0 ; RLB
dup SZADDR ; RLB | RLB
lpb ; RLB | RAB
exg SZADDR ; RAB | RLB
sbs SZWORD ; Amount to be moved
dup SZWORD ; A | A
stl -SZWORD ; A
lor 0 ; A | SLB
dup SZADDR ; A | SLB | SLB
lpb ; A | SLB | SAB
exg SZADDR ; A | SAB | SLB
sbs SZWORD ; A | SA (the size of our own return status block)
exg SZWORD ; SA | A
sbi SZWORD ; SA-A
lor 0 ; SLB
ads SZWORD ; new SLB to be
str 1 ; set SP there
lor 1 ; TO (=SP the destination of the move)
dup SZADDR ; TO | TO
LFL 0 ; TO | TO | RLB (the source of the move)
exg SZADDR ; TO | RLB | TO
lol -SZWORD ; TO | RLB | TO | A
bls SZWORD ; TO
str 0 ; set SLB to the moved copy of RNSTART's block
ret 0 ; return to RNSTART's caller, resetting his registers
end SZWORD ; one local to store A
#endif
pro $GETCALLE,0 ; returns LB of nearest A68 frame on stack, A68 caller
LFL SZADDR ; param (lb of callee, routine) (after static link)
1
dch ; follow dynamic chain
dup SZADDR ; duplicate either to return or follow next time
lof -SZWORD ; lb - SZWORD is addres of frame stamp
loc A68STAMP
bne *1 ; do again if not A68 frame
ret SZADDR ; return lb of frame
end 0
pro $ISA68,0
LFL SZADDR ; get param, lb of frame to test
adp -SZWORD
loi SZWORD ; load frame stamp
loc A68STAMP
cmi SZWORD ; compare it with 'a68stamp'
teq ; is it the same
ret SZWORD ; return answer, true=1 false=0
end 0
pro $ISPUT,0
LFL SZADDR ; get param, lb of frame to test
adp -SZWORD
loi SZWORD ; load frame stamp
loc PUTSTAMP
cmi SZWORD ; compare it with 'putstamp'
teq
ret SZWORD ; return answer, true=1 false=0
end 0
pro $ISGET,0
LFL SZADDR ; get param, lb of frame to test
adp -SZWORD
loi SZWORD ; load frame stamp
loc GETSTAMP
cmi SZWORD ; compare it with 'getstamp'
teq
ret SZWORD ; return answer, true=1 false=0
end 0

36
lang/a68s/liba68s/cleanup.c Normal file
View file

@ -0,0 +1,36 @@
/* $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 */
/* extracted from hlt.c by C.H. Lindsey */
#include <pc_file.h>
extern char *_hbase;
extern int *_extfl;
extern _cls();
extern exit();
_cleanup() {
int i;
for (i = 1; i <= _extfl[0]; i++)
if (_extfl[i] != -1)
_cls(EXTFL(i));
return;
}

52
lang/a68s/liba68s/collp.p Normal file
View file

@ -0,0 +1,52 @@
20000 #include "rundecs.h"
20010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
20020 (**)
20030 (**)
20040 PROCEDURE PCINCR (STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN ;
20050 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); EXTERN;
20060 (**)
20070 (**)
20080 FUNCTION COLLTP(TEMP:NAKEGER; UNIT: OBJECTP; TEMPLATE: DPOINT; OFFSET: OFFSETRANGE): ASNAKED;
20090 (*PCOLLTOTAL+3*)
20100 VAR OBJECT, STRUCTPTR: OBJECTP;
20110 COUNT: INTEGER;
20120 BEGIN WITH TEMP DO WITH NAK DO
20130 BEGIN
20140 OBJECT := INCPTR(POINTER, OFFSET);
20150 STRUCTPTR := UNIT;
20160 IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
20170 MOVELEFT(STRUCTPTR, OBJECT, ORD(TEMPLATE))
20180 ELSE (*STRUCT*)
20190 BEGIN
20200 PCINCR(INCPTR(STRUCTPTR, STRUCTCONST), TEMPLATE, +INCRF);
20210 MOVELEFT(INCPTR(STRUCTPTR, STRUCTCONST), OBJECT, TEMPLATE^[0]);
20220 IF FPTST(STRUCTPTR^) THEN GARBAGE(STRUCTPTR);
20230 END;
20240 COLLTP := ASNAK;
20250 END
20260 END;
20270 (**)
20280 (**)
20290 FUNCTION COLLNP(TEMP: NAKEGER; NAKUNIT: NAKEGER; TEMPLATE: DPOINT; OFFSET: OFFSETRANGE): ASNAKED;
20300 (*PCOLLNAKED+3*)
20310 VAR OBJECT: UNDRESSP;
20320 COUNT: INTEGER;
20330 BEGIN WITH TEMP DO WITH NAK DO
20340 BEGIN
20350 OBJECT := INCPTR(POINTER, OFFSET);
20360 WITH NAKUNIT.NAK DO
20370 BEGIN
20380 PCINCR(POINTER, TEMPLATE, +INCRF);
20390 MOVELEFT(POINTER, OBJECT, TEMPLATE^[0]);
20400 IF FPTST(STOWEDVAL^) THEN GARBAGE(STOWEDVAL);
20410 END;
20420 COLLNP := ASNAK;
20430 END
20440 END;
20450 (**)
20460 (**)
20470 (*-02() BEGIN END ; ()-02*)
20480 (*+01()
20490 BEGIN (*OF MAIN PROGRAM*)
20500 END (*OF EVERYTHING*).
20510 ()+01*)

57
lang/a68s/liba68s/colltm.p Normal file
View file

@ -0,0 +1,57 @@
20600 #include "rundecs.h"
20610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
20620 (**)
20630 (**)
20640 PROCEDURE ERRORR(N :INTEGER); EXTERN;
20650 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); EXTERN;
20660 FUNCTION NEXTEL(I: INTEGER; VAR PDESC1: PDESC): BOOLEAN; EXTERN;
20670 PROCEDURE PCINCRSLICE(MULT: OBJECTP; VAR APDESC: PDESC; INCREMENT: INTEGER); EXTERN;
20680 PROCEDURE PCINCRMULT(ELSPTR: OBJECTP; INCREMENT: INTEGER); EXTERN;
20690 PROCEDURE FORMPDESC(OLDESC: OBJECTP; VAR PDESC1: PDESC); EXTERN;
20700 (**)
20710 (**)
20720 FUNCTION COLLTM(TEMP: NAKEGER; SOURCEMULT: OBJECTP; OFFSET: OFFSETRANGE): ASNAKED;
20730 (*PCOLLTOTAL+4*)
20740 VAR DESTMULT: OBJECTP;
20750 SOURCELS: OBJECTP;
20760 PDESC1: PDESC;
20770 COUNT: INTEGER;
20780 BEGIN
20790 WITH TEMP DO WITH NAK DO
20800 BEGIN
20810 DESTMULT := STOWEDVAL;
20820 WITH SOURCEMULT^ DO
20830 FOR COUNT := 0 TO ROWS DO WITH DESCVEC[COUNT] DO
20840 IF (LI<>DESTMULT^.DESCVEC[COUNT].LI)
20850 OR (UI<>DESTMULT^.DESCVEC[COUNT].UI) THEN
20860 ERRORR(RMULASS);
20870 SOURCELS := SOURCEMULT^.PVALUE;
20880 COUNT := OFFSET;
20890 IF SOURCEMULT^.BPTR<>NIL THEN (*A SLICE*)
20900 BEGIN
20910 FORMPDESC(SOURCEMULT, PDESC1);
20920 PCINCRSLICE(SOURCEMULT, PDESC1, +INCRF);
20930 WITH POINTER^ DO
20940 WHILE NEXTEL(0, PDESC1) DO WITH PDESC1 DO WITH PDESCVEC[0] DO
20950 BEGIN
20960 MOVELEFT(INCPTR(SOURCELS, PP), INCPTR(POINTER, COUNT), PSIZE);
20970 COUNT := COUNT+PSIZE;
20980 END;
20990 END
21000 ELSE (*NOT A SLICE*)
21010 BEGIN
21020 PCINCRMULT(SOURCELS, +INCRF);
21030 MOVELEFT(INCPTR(SOURCELS, ELSCONST), INCPTR(POINTER, COUNT), SOURCELS^.D0);
21040 END;
21050 POINTER := INCPTR(POINTER, COUNT-OFFSET);
21060 COLLTM := ASNAK;
21070 END;
21080 IF FPTST(SOURCEMULT^) THEN GARBAGE(SOURCEMULT)
21090 END;
21100 (**)
21110 (**)
21120 (*-02() BEGIN END ; ()-02*)
21130 (*+01()
21140 BEGIN (*OF MAIN PROGRAM*)
21150 END (*OF EVERYTHING*).
21160 ()+01*)

50
lang/a68s/liba68s/collts.p Normal file
View file

@ -0,0 +1,50 @@
21800 #include "rundecs.h"
21810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
21820 (**)
21830 (**)
21840 (*-01() (*-05()
21850 FUNCTION COLLTS(TEMP: NAKEGER; UNIT: A68INT; OFFSET: OFFSETRANGE): ASNAKED;
21860 (*PCOLLTOTAL - USUALLY CODED INLINE*)
21870 VAR OBJECT: UNDRESSP;
21880 BEGIN WITH TEMP DO WITH NAK DO
21890 BEGIN
21900 OBJECT := INCPTR(POINTER, OFFSET);
21910 OBJECT^.FIRSTINT := UNIT;
21920 COLLTS := ASNAK;
21930 END
21940 END;
21950 (**)
21960 (**)
21970 FUNCTION COLLTS2(TEMP: NAKEGER; UNIT: A68LONG; OFFSET: OFFSETRANGE): ASNAKED;
21980 (*PCOLLTOTAL+1 - USUALLY CODED INLINE*)
21990 VAR OBJECT: UNDRESSP;
22000 BEGIN WITH TEMP DO WITH NAK DO
22010 BEGIN
22020 OBJECT := INCPTR(POINTER, OFFSET);
22030 OBJECT^.FIRSTLONG := UNIT;
22040 COLLTS2 := ASNAK;
22050 END
22060 END;
22070 (**)
22080 (**)
22090 FUNCTION COLLTPT(TEMP: NAKEGER; UNIT: OBJECTP; OFFSET: OFFSETRANGE): ASNAKED;
22100 (*PCOLLTOTAL+2 - USUALLY CODED INLINE*)
22110 VAR OBJECT: UNDRESSP ;
22120 BEGIN WITH TEMP DO WITH NAK DO
22130 BEGIN
22140 OBJECT := INCPTR(POINTER, OFFSET);
22150 WITH OBJECT^ DO
22160 BEGIN FIRSTPTR := UNIT; WITH FIRSTPTR^ DO FINC END;
22170 COLLTPT := ASNAK;
22180 END
22190 END;
22200 (**)
22210 (**)
22220 ()-05*) ()-01*)
22230 (**)
22240 (**)
22250 (*-02() BEGIN END ; ()-02*)
22260 (*+01()
22270 BEGIN (*OF MAIN PROGRAM*)
22280 END (*OF EVERYTHING*).
22290 ()+01*)

294
lang/a68s/liba68s/complex.p Normal file
View file

@ -0,0 +1,294 @@
22300 #include "rundecs.h"
22310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
22320 (**)
22330 PROCEDURE ERRORR(N: INTEGER);EXTERN;
22340 PROCEDURE GARBAGE(ANOBJECT: OBJECTP);EXTERN;
22350 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
22360 (**)
22370 (**)
22380 FUNCTION CRCOMPLEX(REPART,IMAGPART: REAL): OBJECTP;
22390 VAR NEWCOMPLEX: OBJECTP;
22400 BEGIN
22410 ENEW(NEWCOMPLEX, STRUCTCONST+2*SZREAL);
22420 WITH NEWCOMPLEX^ DO
22430 BEGIN
22440 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
22450 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
22460 LENGTH := STRUCTCONST+2*SZREAL;
22470 DBLOCK := COMPLEX;
22480 RE := REPART;
22490 IM := IMAGPART
22500 END;
22510 CRCOMPLEX := NEWCOMPLEX
22520 END;
22530 (**)
22540 (**)
22550 FUNCTION WIDREAL(REA: REAL): OBJECTP;
22560 (*PWIDEN+2*)
22570 BEGIN
22580 WIDREAL := CRCOMPLEX(REA,0.0)
22590 END;
22600 (**)
22610 (**)
22620 FUNCTION CPLUS(LEFT,RIGHT: OBJECTP): OBJECTP;
22630 VAR NEWOBJ: OBJECTP;
22640 BEGIN
22650 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22660 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
22670 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
22680 WITH NEWOBJ^ DO
22690 BEGIN
22700 RE := LEFT^.RE+RIGHT^.RE;
22710 IM := LEFT^.IM+RIGHT^.IM
22720 END;
22730 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
22740 CPLUS := NEWOBJ
22750 END;
22760 (**)
22770 (**)
22780 FUNCTION CMINUS(LEFT,RIGHT: OBJECTP): OBJECTP;
22790 VAR NEWOBJ: OBJECTP;
22800 BEGIN
22810 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22820 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
22830 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
22840 WITH NEWOBJ^ DO
22850 BEGIN
22860 RE := LEFT^.RE-RIGHT^.RE;
22870 IM := LEFT^.IM-RIGHT^.IM
22880 END;
22890 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
22900 CMINUS := NEWOBJ
22910 END;
22920 (**)
22930 (**)
22940 FUNCTION CTIMS(LEFT,RIGHT: OBJECTP): OBJECTP;
22950 VAR NEWOBJ: OBJECTP;
22960 TEMPREAL: REAL;
22970 BEGIN
22980 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22990 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
23000 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23010 TEMPREAL := LEFT^.RE*RIGHT^.RE-LEFT^.IM*RIGHT^.IM;
23020 WITH NEWOBJ^ DO
23030 BEGIN
23040 IM := LEFT^.RE*RIGHT^.IM+LEFT^.IM*RIGHT^.RE;
23050 RE := TEMPREAL
23060 END;
23070 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
23080 CTIMS := NEWOBJ
23090 END;
23100 (**)
23110 (**)
23120 FUNCTION CDIV(LEFT,RIGHT: OBJECTP): OBJECTP;
23130 VAR NEWOBJ: OBJECTP;
23140 TEMPREAL,RIGHTSQR: REAL;
23150 BEGIN
23160 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
23170 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
23180 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23190 RIGHTSQR := SQR(RIGHT^.RE)+SQR(RIGHT^.IM);
23200 TEMPREAL := (LEFT^.RE*RIGHT^.RE+LEFT^.IM*RIGHT^.IM)/RIGHTSQR;
23210 WITH NEWOBJ^ DO
23220 BEGIN
23230 IM := (LEFT^.IM*RIGHT^.RE-LEFT^.RE*RIGHT^.IM)/RIGHTSQR;
23240 RE := TEMPREAL
23250 END;
23260 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
23270 CDIV := NEWOBJ
23280 END;
23290 (**)
23300 (**)
23310 FUNCTION CNEGI(CNUMB: OBJECTP): OBJECTP;
23320 VAR NEWOBJ: OBJECTP;
23330 BEGIN
23340 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
23350 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23360 WITH NEWOBJ^ DO
23370 BEGIN
23380 RE := -CNUMB^.RE;
23390 IM := -CNUMB^.IM
23400 END;
23410 CNEGI := NEWOBJ
23420 END;
23430 (**)
23440 (**)
23450 FUNCTION CCONJ(CNUMB: OBJECTP): OBJECTP;
23460 VAR NEWOBJ: OBJECTP;
23470 BEGIN
23480 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
23490 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23500 WITH NEWOBJ^ DO
23510 BEGIN
23520 RE := CNUMB^.RE;
23530 IM := -CNUMB^.IM
23540 END;
23550 CCONJ := NEWOBJ
23560 END;
23570 (**)
23580 (**)
23590 FUNCTION CRE(CNUMB: OBJECTP): REAL;
23600 BEGIN
23610 CRE := CNUMB^.RE;
23620 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23630 END;
23640 (**)
23650 (**)
23660 FUNCTION CIM(CNUMB: OBJECTP): REAL;
23670 BEGIN
23680 CIM := CNUMB^.IM;
23690 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23700 END;
23710 (**)
23720 (**)
23730 FUNCTION CABSI(CNUMB: OBJECTP): REAL;
23740 BEGIN
23750 WITH CNUMB^ DO
23760 CABSI := SQRT(SQR(RE)+SQR(IM));
23770 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23780 END;
23790 (**)
23800 (**)
23810 FUNCTION ARG(CNUMB: OBJECTP): REAL;
23820 VAR RESULT: REAL;
23830 BEGIN
23840 WITH CNUMB^ DO
23850 IF (RE<>0.0) OR (IM<>0.0) THEN
23860 IF ABS(RE)>ABS(IM) THEN
23870 RESULT := ARCTAN(IM/RE)+HALFPI.ACTUALPI*(1-ORD(RE>0.0))*2*(1-2*ORD(IM<0.0))
23880 ELSE RESULT := -ARCTAN(RE/IM)+HALFPI.ACTUALPI*(ORD(IM>0.0)-ORD(IM<0.0))
23890 ELSE ERRORR(RARG);
23900 ARG := RESULT
23910 END;
23920 (**)
23930 (**)
23940 FUNCTION CARG(CNUMB: OBJECTP): REAL;
23950 BEGIN
23960 CARG := ARG(CNUMB);
23970 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23980 END;
23990 (**)
24000 (**)
24010 FUNCTION CPOW(CNUMB: OBJECTP;POW: INTEGER): OBJECTP;
24020 VAR NEWOBJ: OBJECTP;
24030 CMOD,CMODPOW,NTHETA: REAL;
24040 NEGPOW: BOOLEAN;
24050 BEGIN
24060 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
24070 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
24080 WITH CNUMB^ DO
24090 CMOD := SQRT(SQR(RE)+SQR(IM));
24100 IF CMOD<>0.0 THEN
24110 BEGIN
24120 NEGPOW := POW<0;
24130 POW := ABS(POW);
24140 NTHETA := POW*ARG(CNUMB);
24150 CMODPOW := 1;
24160 WHILE POW<>0 DO
24170 BEGIN
24180 IF POW MOD 2=1 THEN CMODPOW := CMODPOW*CMOD;
24190 CMOD := SQR(CMOD);
24200 POW := POW DIV 2
24210 END;
24220 WITH NEWOBJ^ DO
24230 BEGIN
24240 RE := COS(NTHETA)*CMODPOW;
24250 IM := SIN(NTHETA)*CMODPOW;
24260 IF NEGPOW THEN
24270 BEGIN
24280 CMOD := SQR(RE)+SQR(IM);
24290 RE := RE/CMOD;
24300 IM := -IM/CMOD
24310 END
24320 END
24330 END
24340 ELSE WITH NEWOBJ^ DO
24350 BEGIN
24360 RE := 0.0;
24370 IM := 0.0
24380 END;
24390 CPOW := NEWOBJ;
24400 END;
24410 (**)
24420 (**)
24430 FUNCTION CEQ(LEFT,RIGHT: OBJECTP): INTEGER;
24440 VAR EQUALS: BOOLEAN;
24450 BEGIN
24460 EQUALS := (LEFT^.RE=RIGHT^.RE) AND (LEFT^.IM=RIGHT^.IM);
24470 IF FPTST(LEFT^) THEN GARBAGE(LEFT);
24480 IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
24490 IF EQUALS THEN CEQ := TRUEVAL ELSE CEQ := 0
24500 END;
24510 (**)
24520 (**)
24530 FUNCTION CNE(LEFT,RIGHT: OBJECTP): INTEGER;
24540 VAR NOTEQUAL: BOOLEAN;
24550 BEGIN
24560 NOTEQUAL := (LEFT^.RE<>RIGHT^.RE) OR (LEFT^.IM<>RIGHT^.IM);
24570 IF FPTST(LEFT^) THEN GARBAGE(LEFT);
24580 IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
24590 IF NOTEQUAL THEN CNE := TRUEVAL ELSE CNE := 0
24600 END;
24610 (**)
24620 (**)
24630 FUNCTION CPLUSAB(DESTINATION,INCREMENT: OBJECTP): OBJECTP;
24640 VAR REALPTR: UNDRESSP;
24650 BEGIN
24660 REALPTR := SAFEACCESS(DESTINATION);
24670 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.RE;
24680 REALPTR := INCPTR(REALPTR,SZREAL);
24690 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.IM;
24700 IF FPTST(INCREMENT^) THEN GARBAGE(INCREMENT);
24710 CPLUSAB := DESTINATION
24720 END;
24730 (**)
24740 (**)
24750 FUNCTION CMINAB(DESTINATION,DECREMENT: OBJECTP): OBJECTP;
24760 VAR REALPTR: UNDRESSP;
24770 BEGIN
24780 REALPTR := SAFEACCESS(DESTINATION);
24790 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.RE;
24800 REALPTR := INCPTR(REALPTR,SZREAL);
24810 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.IM;
24820 IF FPTST(DECREMENT^) THEN GARBAGE(DECREMENT);
24830 CMINAB := DESTINATION
24840 END;
24850 (**)
24860 (**)
24870 FUNCTION CTIMSAB(DESTINATION,FACTOR: OBJECTP): OBJECTP;
24880 VAR REALPTR,IMAGPTR: UNDRESSP;
24890 TEMPREAL: REAL;
24900 BEGIN
24910 REALPTR := SAFEACCESS(DESTINATION);
24920 IMAGPTR := INCPTR(REALPTR,SZREAL);
24930 TEMPREAL := REALPTR^.FIRSTREAL*FACTOR^.RE-IMAGPTR^.FIRSTREAL*FACTOR^.IM;
24940 IMAGPTR^.FIRSTREAL := REALPTR^.FIRSTREAL*FACTOR^.IM+IMAGPTR^.FIRSTREAL*FACTOR^.RE;
24950 REALPTR^.FIRSTREAL := TEMPREAL;
24960 IF FPTST(FACTOR^) THEN GARBAGE(FACTOR);
24970 CTIMSAB := DESTINATION
24980 END;
24990 (**)
25000 (**)
25010 FUNCTION CDIVAB(DESTINATION,DIVISOR: OBJECTP): OBJECTP;
25020 VAR REALPTR,IMAGPTR: UNDRESSP;
25030 TEMPREAL,DIVISORSQR: REAL;
25040 BEGIN
25050 REALPTR := SAFEACCESS(DESTINATION);
25060 IMAGPTR := INCPTR(REALPTR,SZREAL);
25070 DIVISORSQR := SQR(DIVISOR^.RE)+SQR(DIVISOR^.IM);
25080 TEMPREAL := (REALPTR^.FIRSTREAL*DIVISOR^.RE+IMAGPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
25090 IMAGPTR^.FIRSTREAL := (IMAGPTR^.FIRSTREAL*DIVISOR^.RE-REALPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
25100 REALPTR^.FIRSTREAL := TEMPREAL;
25110 IF FPTST(DIVISOR^) THEN GARBAGE(DIVISOR);
25120 CDIVAB := DESTINATION
25130 END;
25140 (**)
25150 (**)
25160 (*-02()
25170 BEGIN (* OF A68 *)
25180 END (* OF A68 *);
25190 ()-02*)
25200 (*+01()
25210 BEGIN (* OF MAIN PROGRAM *)
25220 END (* OF MAIN PROGRAM *).
25230 ()+01*)

4
lang/a68s/liba68s/cos.c Normal file
View file

@ -0,0 +1,4 @@
extern double _cos();
double COS(statlink, x)
int *statlink; double x;
{return(_cos(x));}

154
lang/a68s/liba68s/crmult.p Normal file
View file

@ -0,0 +1,154 @@
26000 #include "rundecs.h"
26010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
26020 (**)
26030 (**)
26040 PROCEDURE COPYSLICE(ASLICE: OBJECTP); EXTERN;
26050 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
26060 PROCEDURE ERRORR(N :INTEGER); EXTERN;
26070 (**)
26080 (**)
26090 FUNCTION BOUND(ROWCOUNT: INTEGER): OBJECTP;
26100 (*PBOUNDS*)
26110 VAR NEWMULT: OBJECTP;
26120 DESCDEX: INTEGER; BND: BOUNDSRANGE;
26130 BEGIN
26140 ENEW(NEWMULT, MULTCONST+ROWCOUNT*SZPDS);
26150 WITH NEWMULT^ DO
26160 BEGIN
26170 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
26180 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
26190 (*+01() SECONDWORD := 0; ()+01*)
26200 OSCOPE := 0 ;
26210 FOR DESCDEX := 0 TO ROWCOUNT-1 DO
26220 WITH DESCVEC[DESCDEX] DO
26230 BEGIN
26240 BND := GETSTKTOP(SZINT, DESCDEX*2*SZINT);
26250 IF BND=INTUNDEF THEN ERRORR(RCUPPER); UI := BND;
26260 BND := GETSTKTOP(SZINT, DESCDEX*2*SZINT+SZINT);
26270 IF BND=INTUNDEF THEN ERRORR(RCLOWER); LI := BND;
26280 END;
26290 ROWS := ROWCOUNT-1;
26300 PVALUE := NIL;
26310 IHEAD := NIL; FPTR := NIL; BPTR := NIL
26320 END;
26330 BOUND := NEWMULT;
26340 END;
26350 (**)
26360 (**)
26370 FUNCTION CRMULT(NEWMULT: OBJECTP; TEMPLATE: DPOINT): OBJECTP;
26380 (*PACTDRMULT*)
26390 VAR NEWELS: OBJECTP;
26400 SUM, ELSIZE, INDEX, DESCDEX, TEMPOS, STRUCTPOS, INC: INTEGER;
26410 PTR, LIMIT: UNDRESSP;
26420 BEGIN
26430 WITH NEWMULT^ DO
26440 BEGIN
26450 IF ORD(TEMPLATE)=0 THEN ELSIZE := SZADDR (*DRESSED*)
26460 ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN ELSIZE := ORD(TEMPLATE) (*UNDRESSED*)
26470 ELSE ELSIZE := TEMPLATE^[0]; (*STRUCT*)
26480 SIZE:= ELSIZE;
26490 SUM:= 0;
26500 FOR DESCDEX := 0 TO ROWS DO
26510 WITH DESCVEC[DESCDEX] DO
26520 BEGIN
26530 DI:= ELSIZE;
26540 SUM := SUM+LI*ELSIZE;
26550 ELSIZE:= (UI-LI+1)*ELSIZE;
26560 IF ELSIZE <= 0 THEN
26570 ELSIZE:= 0
26580 END;
26590 LBADJ := SUM-ELSCONST;
26600 MDBLOCK := TEMPLATE;
26610 ENEW(NEWELS, ELSCONST+ELSIZE);
26620 WITH NEWELS^ DO
26630 BEGIN
26640 (*-02() FIRSTWORD := SORTSHIFT*ORD(IELS)+INCRF; ()-02*)
26650 (*+02() PCOUNT:=1; SORT:=IELS; ()+02*)
26660 OSCOPE := 0;
26670 DBLOCK:= TEMPLATE;
26680 D0:= ELSIZE;
26690 CCOUNT:= 1;
26700 PTR := INCPTR(NEWELS, ELSCONST);
26710 IHEAD := NIL;
26720 (*-02()
26730 IF ORD(TEMPLATE)=0 THEN BEGIN PTR^.FIRSTPTR := UNDEFIN; INC := SZADDR END (*DRESSED*)
26740 ELSE BEGIN PTR^.FIRSTWORD := INTUNDEF; INC := SZWORD END; (*UNDRESSED*)
26750 MOVELEFT(PTR, INCPTR(PTR, INC), ELSIZE-INC);
26760 ()-02*)
26770 (*+02()
26780 LIMIT := INCPTR(PTR, ELSIZE);
26790 IF ORD(TEMPLATE)=0 THEN WHILE PTR<>LIMIT DO
26800 BEGIN PTR^.FIRSTPTR := UNDEFIN; PTR := INCPTR(PTR, SZADDR) END
26810 ELSE WHILE PTR<>LIMIT DO
26820 BEGIN PTR^.FIRSTWORD := INTUNDEF; PTR := INCPTR(PTR, SZWORD) END;
26830 ()+02*)
26840 IF ORD(TEMPLATE)>MAXSIZE (*STRUCT*) THEN
26850 BEGIN
26860 ELSIZE:= TEMPLATE^[0];
26870 INDEX:= 0;
26880 WHILE INDEX < D0 DO
26890 BEGIN
26900 TEMPOS:= 1;
26910 STRUCTPOS:= TEMPLATE^[1];
26920 WHILE STRUCTPOS >= 0 DO
26930 BEGIN
26940 PTR := INCPTR(NEWELS, ELSCONST+INDEX+STRUCTPOS);
26950 PTR^.FIRSTPTR := UNDEFIN;
26960 TEMPOS:= TEMPOS+1;
26970 STRUCTPOS:= TEMPLATE^[TEMPOS]
26980 END;
26990 INDEX:= INDEX+ELSIZE
27000 END
27010 END
27020 END;
27030 PVALUE:= NEWELS
27040 END;
27050 CRMULT := NEWMULT
27060 END;
27070 (**)
27080 (**)
27090 FUNCTION CRREFR(ANOBJECT: OBJECTP): OBJECTP;
27100 (*PCREATEREF+2*)
27110 VAR NEWREFR: OBJECTP;
27120 BEGIN
27130 WITH ANOBJECT^ DO
27140 BEGIN
27150 IF (BPTR<>NIL) AND (SORT=MULT) THEN (*SOURCE IS A SLICE*)
27160 COPYSLICE(ANOBJECT);
27170 IF FTST THEN
27180 BEGIN NEWREFR := ANOBJECT; NEWREFR^.SORT := REFR END
27190 ELSE
27200 BEGIN
27210 NEWREFR := COPYDESC(ANOBJECT, REFR);
27220 WITH NEWREFR^.PVALUE^ DO FINC
27230 END
27240 END;
27250 WITH NEWREFR^ DO
27260 BEGIN
27270 OSCOPE := SCOPE+FIRSTRG.RIBOFFSET^.RGSCOPE;
27280 ANCESTOR:= NEWREFR;
27290 CCOUNT:= 1;
27300 END;
27310 CRREFR := NEWREFR;
27320 END;
27330 (**)
27340 (**)
27350 FUNCTION CHKDESC(SOURCEMULT, CDESC: OBJECTP): OBJECTP;
27360 (*PCHECKDESC*)
27370 VAR COUNT: INTEGER;
27380 BEGIN
27390 IF SOURCEMULT^.SORT=UNDEF THEN ERRORR(RMULASS);
27400 FOR COUNT:= 0 TO CDESC^.ROWS
27410 DO WITH CDESC^.DESCVEC[COUNT], SOURCEMULT^ DO
27420 IF (LI <> DESCVEC[COUNT].LI)
27430 OR (UI <> DESCVEC[COUNT].UI)
27440 THEN ERRORR(RMULASS);
27450 CHKDESC := SOURCEMULT;
27460 END;
27470 (**)
27480 (**)
27490 (*-02() BEGIN END ; ()-02*)
27500 (*+01()
27510 BEGIN (*OF MAIN PROGRAM*)
27520 END (*OF EVERYTHING*).
27530 ()+01*)

29
lang/a68s/liba68s/crrefn.p Normal file
View file

@ -0,0 +1,29 @@
27600 #include "rundecs.h"
27610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
27620 (**)
27630 (**)
27640 FUNCTION CRREFN(ANOBJECT: OBJECTP): OBJECTP;
27650 (*PCREATEREF*)
27660 VAR NEWREFN: OBJECTP;
27670 BEGIN
27680 ENEW(NEWREFN, REFNSIZE);
27690 WITH NEWREFN^ DO
27700 BEGIN
27710 (*-02() FIRSTWORD := SORTSHIFT * ORD(REFN); ()-02*)
27720 (*+02() PCOUNT:=0; SORT:=REFN; ()+02*)
27730 (*+01() SECONDWORD := 0; ()+01*)
27740 ANCESTOR := NEWREFN;
27750 OFFSET := STRUCTCONST;
27760 PVALUE := ANOBJECT;
27770 OSCOPE := SCOPE+FIRSTRG.RIBOFFSET^.RGSCOPE;
27780 WITH ANOBJECT^ DO FINC;
27790 END;
27800 CRREFN := NEWREFN;
27810 END;
27820 (**)
27830 (**)
27840 (*-02() BEGIN END ; ()-02*)
27850 (*+01()
27860 BEGIN (*OF MAIN PROGRAM*)
27870 END (*OF EVERYTHING*).
27880 ()+01*)

42
lang/a68s/liba68s/dclpsn.p Normal file
View file

@ -0,0 +1,42 @@
28000 #include "rundecs.h"
28010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
28020 (**)
28030 (**)
28040 PROCEDURE DCLSN( COUNT: DEPTHRANGE ; OFFSET: OFFSETRANGE ) ;
28050 VAR PTR: UNDRESSP ;
28060 I : INTEGER ;
28070 BEGIN
28080 PTR := INCPTR( ASPTR(STATIC( ME )) , (*+41() - ()+41*) OFFSET ) ;
28090 FOR I := COUNT DIV SZINT - 1 DOWNTO 0 DO
28100 BEGIN
28110 (*+41() PTR := INCPTR( PTR , - SZINT ) ; ()+41*)
28120 PTR ^.FIRSTINT := GETSTKTOP( SZINT , SZINT * I ) ;
28130 (*-41() PTR := INCPTR( PTR , SZINT ) ()-41*)
28140 END
28150 END ;
28160 (**)
28170 PROCEDURE DCLPN( COUNT: DEPTHRANGE ; OFFSET: OFFSETRANGE ) ;
28180 VAR PTR: UNDRESSP ;
28190 I: INTEGER ;
28200 BEGIN
28210 PTR := INCPTR( ASPTR(STATIC( ME )) , (*+41() - ()+41*) OFFSET ) ;
28220 FOR I := COUNT DIV SZADDR - 1 DOWNTO 0 DO
28230 BEGIN
28240 (*+41() PTR := INCPTR( PTR , - SZADDR ) ; ()+41*)
28250 PTR ^.FIRSTPTR := ASPTR(GETSTKTOP( SZADDR , SZADDR * I )) ;
28260 WITH PTR ^ DO
28270 WITH FIRSTPTR ^ DO
28280 FINC;
28290 (*-41() PTR := INCPTR( PTR , SZADDR ) ()-41*)
28300 END
28310 END ;
28320 (**)
28330 (**)
28340 (*-02()
28350 BEGIN
28360 END ;
28370 ()-02*)
28380 (*+01()
28390 BEGIN (*OF MAIN PROGRAM*)
28400 END (*OF EVERYTHING*).
28410 ()+01*)

18
lang/a68s/liba68s/div.e Normal file
View file

@ -0,0 +1,18 @@
#include "e.h"
exp $DIV
pro $DIV,SZWORD
loc PASCALSTAMP
stl -SZWORD
lol SZADDR+SZWORD ; 1st param
loc SZWORD
loc SZREAL
cif
lol SZADDR ; 2nd param
loc SZWORD
loc SZREAL
cif
dvf SZREAL
ret SZREAL
end SZWORD

57
lang/a68s/liba68s/drefm.p Normal file
View file

@ -0,0 +1,57 @@
28500 #include "rundecs.h"
28510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
28520 (**)
28530 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
28540 PROCEDURE ERRORR(N :INTEGER); EXTERN;
28550 FUNCTION GETMULT(NEWMULT: OBJECTP): OBJECTP; EXTERN;
28560 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
28570 (**)
28580 (**)
28590 FUNCTION DREFM(REFER: OBJECTP): OBJECTP;
28600 (*PDEREF+4*)
28610 VAR NEWMULT:OBJECTP;
28620 BEGIN WITH REFER^ DO
28630 CASE SORT OF
28640 REFR, RECR:
28650 BEGIN
28660 IF FTST THEN
28670 BEGIN
28680 DREFM := REFER;
28690 OSCOPE := PVALUE^.OSCOPE;
28700 SORT := MULT
28710 END
28720 ELSE
28730 BEGIN
28740 NEWMULT := COPYDESC(REFER, MULT);
28750 NEWMULT^.OSCOPE := PVALUE^.OSCOPE;
28760 DREFM := NEWMULT;
28770 FPINC(PVALUE^)
28780 END
28790 END;
28800 REFSLN:
28810 BEGIN
28820 PVALUE := ANCESTOR;
28830 IF FTST THEN
28840 BEGIN
28850 SORT := MULT;
28860 DREFM := GETMULT(REFER);
28870 FPDEC(ANCESTOR^);
28880 IF FPTST(ANCESTOR^) THEN GARBAGE(ANCESTOR);
28890 END
28900 ELSE
28910 DREFM := GETMULT(COPYDESC(REFER, MULT))
28920 END;
28930 UNDEF: ERRORR(RDEREF);
28940 NILL: ERRORR(RDEREFNIL)
28950 END
28960 END;
28970 (**)
28980 (**)
28990 (*-02()
29000 BEGIN
29010 END;
29020 ()-02*)
29030 (*+01()
29040 BEGIN (*OF MAIN PROGRAM*)
29050 END (*OF EVERYTHING*).
29060 ()+01*)

75
lang/a68s/liba68s/drefs.p Normal file
View file

@ -0,0 +1,75 @@
29100 #include "rundecs.h"
29110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
29120 (**)
29130 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
29140 PROCEDURE ERRORR(N :INTEGER); EXTERN;
29150 (**)
29160 (**)
29170 FUNCTION DREFS(REFER: OBJECTP): A68INT;
29180 (*PDEREF*)
29190 VAR PTR: UNDRESSP;
29200 BEGIN WITH REFER^ DO
29210 CASE SORT OF
29220 REF1: DREFS := VALUE;
29230 CREF: DREFS := IPTR^.FIRSTINT;
29240 REFSL1: BEGIN PTR := INCPTR(ANCESTOR^.PVALUE, OFFSET); DREFS := PTR^.FIRSTINT END;
29250 UNDEF: ERRORR(RDEREF);
29260 NILL: ERRORR(RDEREFNIL);
29270 END;
29280 IF FPTST(REFER^) THEN GARBAGE(REFER)
29290 END;
29300 (**)
29310 (**)
29320 (*-01()
29330 FUNCTION DREFS2(REFER: OBJECTP): A68LONG;
29340 (*PDEREF+1*)
29350 VAR PTR: UNDRESSP;
29360 BEGIN WITH REFER^ DO
29370 CASE SORT OF
29380 REF2: DREFS2 := LONGVALUE;
29390 CREF: DREFS2 := IPTR^.FIRSTLONG;
29400 REFSL1: BEGIN PTR := INCPTR(ANCESTOR^.PVALUE, OFFSET); DREFS2 := PTR^.FIRSTLONG END;
29410 UNDEF: ERRORR(RDEREF);
29420 NILL: ERRORR(RDEREFNIL);
29430 END;
29440 IF FPTST(REFER^) THEN GARBAGE(REFER)
29450 END;
29460 (**)
29470 (**)
29480 ()-01*)
29490 (**)
29500 (**)
29510 FUNCTION DREFPTR(REFER: OBJECTP): OBJECTP;
29520 (*PDEREF+2*)
29530 VAR RESULT: OBJECTP;
29540 PTR: UNDRESSP;
29550 BEGIN
29560 WITH REFER^ DO
29570 BEGIN
29580 CASE SORT OF
29590 RECN, REFN: RESULT := PVALUE;
29600 CREF: RESULT := IPTR^.FIRSTPTR;
29610 REFSL1: BEGIN PTR := INCPTR(ANCESTOR^.PVALUE, OFFSET); RESULT := PTR^.FIRSTPTR END;
29620 UNDEF: ERRORR(RDEREF);
29630 NILL: ERRORR(RDEREFNIL);
29640 END;
29650 IF SORT<>CREF THEN WITH RESULT^ DO
29660 BEGIN
29670 FINC;
29680 IF FPTST(REFER^) THEN GARBAGE(REFER);
29690 FDEC
29700 END
29710 ELSE IF FPTST(REFER^) THEN GARBAGE(REFER);
29720 DREFPTR := RESULT;
29730 END
29740 END;
29750 (**)
29760 (**)
29770 (*-02()
29780 BEGIN
29790 END;
29800 ()-02*)
29810 (*+01()
29820 BEGIN (*OF MAIN PROGRAM*)
29830 END (*OF EVERYTHING*).
29840 ()+01*)

21
lang/a68s/liba68s/dumbacch.p Normal file
View file

@ -0,0 +1,21 @@
70900 #include "rundecs.h"
70910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
70920 (**)
70930 (**)
70940 (*+01() (*$X6*) ()+01*)
70950 (**)
70960 PROCEDURE DUMBACCH(PCOV: OBJECTP; LFN: LFNTYPE);
70970 BEGIN PCOV^.POSSIBLES := [] END;
70980 (**)
70990 (**)
71000 (*+01() (*$X4*) ()+01*)
71010 (**)
71020 (**)
71030 (*-02()
71040 BEGIN (*OF A68*)
71050 END; (*OF A68*)
71060 ()-02*)
71070 (*+01()
71080 BEGIN (*OF MAIN PROGRAM*)
71090 END (* OF EVERYTHING *).
71100 ()+01*)

22
lang/a68s/liba68s/duminch.p Normal file
View file

@ -0,0 +1,22 @@
71200 #include "rundecs.h"
71210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
71220 (**)
71230 (*+01() (*$X6*) ()+01*)
71240 (**)
71250 (**)
71260 PROCEDURE DUMINCH(PCOV: OBJECTP; LFN: LFNTYPE);
71270 (*WHEN THERE ARE NOT 'GET'S IN THE PROGRAM*)
71280 BEGIN PCOV^.POSSIBLES := [] ; (*+01() PCOV^.BOOK^.STATUS := 0 ()+01*) END;
71290 (**)
71300 (**)
71310 (*+01() (*$X4*) ()+01*)
71320 (**)
71330 (**)
71340 (*-02()
71350 BEGIN (*OF A68*)
71360 END; (*OF A68*)
71370 ()-02*)
71380 (*+01()
71390 BEGIN (*OF MAIN PROGRAM*)
71400 END (* OF EVERYTHING *).
71410 ()+01*)

20
lang/a68s/liba68s/dummy.p Normal file
View file

@ -0,0 +1,20 @@
29900 #include "rundecs.h"
29910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
29920 (**)
29930 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
29940 (**)
29950 (**)
29960 PROCEDURE DUMMY;
29970 BEGIN
29980 ERRORR(RDUMMY);
29990 END;
30000 (**)
30010 (**)
30020 (*-02()
30030 BEGIN
30040 END ;
30050 ()-02*)
30060 (*+01()
30070 BEGIN (*OF MAIN PROGRAM*)
30080 END (*OF EVERYTHING*).
30090 ()+01*)

27
lang/a68s/liba68s/dumoutch.p Normal file
View file

@ -0,0 +1,27 @@
71500 #include "rundecs.h"
71510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
71520 (**)
71530 (*+01() (*$X6*) ()+01*)
71540 PROCEDURE AOPEN( EFET:FETROOMP; DISP:INTEGER; LFN:LFNTYPE; BUF:IPOINT ); EXTERN;
71550 (**)
71560 (**)
71570 PROCEDURE DUMOUTCH(PCOV: OBJECTP; LFN: LFNTYPE);
71580 BEGIN WITH PCOV^ DO
71590 BEGIN
71600 (**)
71610 POSSIBLES := [];
71620 AOPEN(BOOK, FORWRITE, LFN, ORD(BOOK)+BUFFOFFSET);
71630 END
71640 END;
71650 (**)
71660 (*+01() (*$X4*) ()+01*)
71670 (**)
71680 (**)
71690 (*-02()
71700 BEGIN (*OF A68*)
71710 END; (*OF A68*)
71720 ()-02*)
71730 (*+01()
71740 BEGIN (*OF MAIN PROGRAM*)
71750 END (* OF EVERYTHING *).
71760 ()+01*)

59
lang/a68s/liba68s/e.h Normal file
View file

@ -0,0 +1,59 @@
#define SZADDR EM_PSIZE
#define SZWORD EM_WSIZE
#define SZLONG 4
#define SZREAL 8
#define SZPROC SZADDR+SZADDR
#if SZWORD==2
#if SZADDR==2
#define FIRSTIBOFFSET 30 /* offset from .HTOP to main's LB */
#else
#define FIRSTIBOFFSET 50
#endif
#else
#define FIRSTIBOFFSET 52
#endif
#define FSTAMPOFFSET FIRSTIBOFFSET+SZWORD
/* the following four definitions are offsets to the file pointers */
#define FILEOFFSET SZWORD+SZWORD+SZADDR+SZWORD+SZWORD+SZADDR+SZADDR+SZWORD+\
SZADDR+SZADDR+SZWORD+SZWORD+SZADDR
#define STINOFFSET FIRSTIBOFFSET+FILEOFFSET
#define STOUTOFFSET STINOFFSET+SZADDR
#define STBACKOFFSET STOUTOFFSET+SZADDR
#define ENTRYOFFSET SZADDR+SZWORD
#if SZWORD==2
#define PUTTVARSPACE 150 /* space, or greater used for locals in PUTT */
#define GETTVARSPACE 350 /* space, or greater used for locals in GETT */
#define LLC ldc /* for loading bit patterns */
#else
#define PUTTVARSPACE 300
#define GETTVARSPACE 700
#define LLC loc
#endif
#define HTOP 500 /* this must agree with what the compiler produces */
#define A68STAMP 13476 /* this must agree with version in a68sdec.p */
#define PASCALSTAMP 0 /* must match what the pascal compiler puts down */
#define PUTSTAMP -1
#define GETSTAMP -2
/* this will only work if SZADDR = SWORD*2 or if SZADDR = SZWORD */
#if SZADDR == SZWORD
#define LFL lol
#define SFL stl
#define LFE loe
#define SFE ste
#define LFF lof
#define SFF stf
#else
#define LFL ldl
#define SFL sdl
#define LFE lde
#define SFE sde
#define LFF ldf
#define SFF sdf
#endif
mes 2,SZWORD,SZADDR

231
lang/a68s/liba68s/ensure.p Normal file
View file

@ -0,0 +1,231 @@
71800 #include "rundecs.h"
71810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
71820 (**)
71830 PROCEDURE GARBAGE(ANOBJECT: OBJECTP); EXTERN;
71840 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
71850 PROCEDURE CLPASC2(P1,P2: IPOINT; PROC: ASPROC); EXTERN;
71860 (**)
71870 (**)
71880 (*+01() (*$X4*) ()+01*)
71890 FUNCTION FUNC68(PB: ASNAKED; RF: OBJECTP): BOOLEAN; EXTERN;
71900 (**)
71910 (**)
71920 PROCEDURE NEWLINE(RF:OBJECTP); EXTERN;
71930 PROCEDURE NEWPAGE(RF:OBJECTP); EXTERN;
71940 (**)
71950 (**)
71960 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP);
71970 BEGIN WITH RF^ DO
71980 CASE SORT OF
71990 REFN: F:=PVALUE;
72000 REFSL1: F := INCPTR(ANCESTOR^.PVALUE, OFFSET-STRUCTCONST);
72010 UNDEF: ERRORR(RDEREF);
72020 NILL: ERRORR(RDEREFNIL)
72030 END (*CASE*)
72040 END;
72050 (**)
72060 (**)
72070 FUNCTION GETPROC(RN: OBJECTP): ASNAKED;
72080 VAR TEMP: NAKEGER;
72090 BEGIN
72100 (*+01() TEMP.ASNAK := 0; ()+01*)
72110 WITH RN^, TEMP.NAK DO
72120 IF SORT=ROUTINE THEN
72130 BEGIN
72140 STOWEDVAL := ASPTR(ENVCHAIN); POINTER := ASPTR(ORD(PROCBL));
72150 IF FTST THEN GARBAGE(RN);
72160 END
72170 ELSE IF SORT=PASCROUT THEN
72180 BEGIN
72190 (*-01() STOWEDVAL := NIL; ()-01*)
72200 PASCPARAMS := PPARAMS; PASCPROC := PPROCBL ;
72210 POINTER := ASPTR(ORD(PASCADDR));
72220 IF FTST THEN GARBAGE(RN);
72230 END
72240 ELSE ERRORR(RROUTIN);
72250 GETPROC := TEMP.ASNAK;
72260 END;
72270 (**)
72280 (**)
72290 PROCEDURE SETREADMOOD(PCOV:OBJECTP);
72300 BEGIN WITH PCOV^ DO
72310 IF NOT([READMOOD]<=STATUS) THEN
72320 BEGIN IF NOT([GETPOSS]<=POSSIBLES)
72330 THEN ERRORR(NOREAD)
72340 ELSE IF [OPENED,WRITEMOOD,BINMOOD,NOTSET]<=STATUS THEN
72350 ERRORR(NOALTER)
72360 ELSE BEGIN (* BOOK NOT INITIALISED *)
72370 STATUS:=STATUS+[READMOOD]-[WRITEMOOD];
72380 IF NOTRESET IN STATUS THEN
72390 CLPASC2(ORD(PCOV), ORD(BOOK), DORESET)
72400 END;
72410 IF PFE IN STATUS THEN STATUS := STATUS-[PFE]+[LFE]
72420 (*ONLY APPLIES TO ASSOCIATED FILES FOR NOW*)
72430 END (* WITH *)
72440 END;
72450 (**)
72460 (**)
72470 PROCEDURE SETWRITEMOOD(PCOV:OBJECTP);
72480 BEGIN
72490 WITH PCOV^ DO
72500 IF NOT([WRITEMOOD]<=STATUS) THEN
72510 BEGIN IF NOT([PUTPOSS]<=POSSIBLES)
72520 THEN ERRORR(NOWRITE)
72530 ELSE IF [OPENED,READMOOD,BINMOOD,NOTSET]<=STATUS THEN
72540 ERRORR(NOALTER)
72550 ELSE BEGIN STATUS:=STATUS+[WRITEMOOD]-[READMOOD,LFE];
72560 IF NOTRESET IN STATUS THEN
72570 CLPASC2(ORD(PCOV), ORD(BOOK), DORESET)
72580 END;
72590 IF POFCPOS>PAGEBOUND THEN STATUS := STATUS+[PFE];
72600 END (* WITH *)
72610 END;
72620 (**)
72630 (**)
72640 PROCEDURE SETCHARMOOD(PCOV:OBJECTP);
72650 BEGIN WITH PCOV^ DO
72660 IF NOT([CHARMOOD]<=STATUS) THEN
72670 IF [OPENED,BINMOOD,NOTSET]<=STATUS
72680 THEN ERRORR(NOSHIFT)
72690 ELSE STATUS:=STATUS+[CHARMOOD]-[BINMOOD]
72700 END;
72710 (**)
72720 (**)
72730 PROCEDURE SETBINMOOD(PCOV:OBJECTP);
72740 BEGIN WITH PCOV^ DO
72750 IF NOT([BINMOOD]<=STATUS) THEN
72760 IF NOT([BINPOSS]<=POSSIBLES)
72770 THEN ERRORR(NOBIN)
72780 ELSE IF [OPENED,CHARMOOD,NOTSET]<=STATUS
72790 THEN ERRORR(NOSHIFT)
72800 ELSE STATUS:=STATUS+[BINMOOD]-[CHARMOOD]
72810 END;
72820 (**)
72830 (**)
72840 (*******ENSURE ROUTINES*******)
72850 (**)
72860 (**)
72870 PROCEDURE ENSSTATE(RF:OBJECTP;VAR F:OBJECTP;READING:STATUSSET);
72880 BEGIN TESTF(RF,F);
72890 WITH F^ DO
72900 IF NOT (READING<=PCOVER^.STATUS) THEN
72910 IF [OPENED]<=PCOVER^.STATUS
72920 THEN BEGIN
72930 IF [READMOOD]<=READING
72940 THEN SETREADMOOD(PCOVER)
72950 ELSE SETWRITEMOOD(PCOVER);
72960 IF [CHARMOOD]<=READING
72970 THEN SETCHARMOOD(PCOVER)
72980 ELSE SETBINMOOD(PCOVER)
72990 END
73000 ELSE ERRORR(NOTOPEN)
73010 END;
73020 (**)
73030 (**)
73040 FUNCTION ENSLOGICALFILE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN;
73050 (*MOOD OK, LOG FILE GENERALLY NOT*)
73060 VAR OLD: STATUSSET; MENDED: BOOLEAN;
73070 COV: OBJECTP;
73080 BEGIN WITH F^ DO
73090 BEGIN
73100 COV := PCOVER; WITH COV^ DO
73110 BEGIN
73120 IF NOTINITIALIZED IN STATUS THEN
73130 BEGIN
73140 CLPASC2(ORD(COV), ORD(BOOK), DONEWLINE);
73150 LOFCPOS := LOFCPOS-1;
73160 END;
73170 OLD := STATUS;
73180 END;
73190 IF LFE IN OLD THEN
73200 BEGIN
73210 IF LOGICALFILEMENDED=UNDEFIN THEN MENDED := FALSE
73220 ELSE MENDED:=FUNC68(GETPROC(LOGICALFILEMENDED),RF);
73230 ENSSTATE(RF,F,OLD);
73240 IF MENDED THEN
73250 ENSLOGICALFILE:=ENSLOGICALFILE(RF,F)
73260 ELSE ENSLOGICALFILE := FALSE
73270 END
73280 ELSE ENSLOGICALFILE:=TRUE;
73290 END
73300 END;
73310 (**)
73320 (**)
73330 FUNCTION ENSPHYSICALFILE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN;
73340 (* MOOD OK, FILE GENERALLY NOT *)
73350 VAR OLD: STATUSSET; MENDED,LFOK: BOOLEAN;
73360 BEGIN WITH F^ DO
73370 IF [LFE]<=PCOVER^.STATUS
73380 THEN LFOK:=ENSLOGICALFILE(RF,F)
73390 ELSE LFOK:=TRUE;
73400 IF LFOK THEN WITH F^ DO
73410 BEGIN OLD:=PCOVER^.STATUS;
73420 IF [PFE]<=OLD THEN
73430 BEGIN
73440 IF PHYSICALFILEMENDED=UNDEFIN THEN MENDED := FALSE
73450 ELSE MENDED:=FUNC68(GETPROC(PHYSICALFILEMENDED),RF);
73460 ENSSTATE(RF,F,OLD);
73470 IF MENDED
73480 THEN ENSPHYSICALFILE:=ENSPHYSICALFILE(RF,F)
73490 ELSE ERRORR(NOPHYSICAL);
73500 END
73510 ELSE ENSPHYSICALFILE:=TRUE
73520 END
73530 ELSE ENSPHYSICALFILE:=FALSE;
73540 END;
73550 (**)
73560 (**)
73570 FUNCTION ENSPAGE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN;
73580 (* MOOD OK, PAGE GENERALLY NOT *)
73590 VAR OLD: STATUSSET; PFOK,MENDED: BOOLEAN;
73600 BEGIN WITH F^ DO
73610 IF([PFE]<=PCOVER^.STATUS) OR ([LFE]<=PCOVER^.STATUS)
73620 THEN PFOK:=ENSPHYSICALFILE(RF,F)
73630 ELSE PFOK:=TRUE;
73640 IF PFOK THEN WITH F^ DO
73650 BEGIN OLD:=PCOVER^.STATUS;
73660 IF [PAGEOVERFLOW]<=OLD THEN
73670 BEGIN
73680 IF PAGEMENDED=UNDEFIN THEN MENDED := FALSE
73690 ELSE MENDED:=FUNC68(GETPROC(PAGEMENDED),RF);
73700 ENSSTATE(RF,F,OLD);
73710 IF NOT MENDED THEN NEWPAGE(RF);
73720 ENSPAGE:=ENSPAGE(RF,F)
73730 END
73740 ELSE ENSPAGE:=TRUE
73750 END
73760 ELSE ENSPAGE:=FALSE;
73770 END;
73780 (**)
73790 (**)
73800 FUNCTION ENSLINE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN;
73810 (* MOOD OK, LINE GENERALLY NOT *)
73820 VAR PAGEOK,MENDED:BOOLEAN; OLD: STATUSSET;
73830 BEGIN WITH F^ DO
73840 IF [PAGEOVERFLOW]<=PCOVER^.STATUS
73850 THEN PAGEOK:=ENSPAGE(RF,F)
73860 ELSE PAGEOK:=TRUE;
73870 IF PAGEOK THEN WITH F^ DO
73880 BEGIN OLD:=PCOVER^.STATUS;
73890 IF [LINEOVERFLOW]<=OLD THEN
73900 BEGIN
73910 IF LINEMENDED=UNDEFIN THEN MENDED := FALSE
73920 ELSE MENDED:=FUNC68(GETPROC(LINEMENDED),RF);
73930 ENSSTATE(RF,F,OLD);
73940 IF NOT MENDED THEN NEWLINE(RF);
73950 ENSLINE:=ENSLINE(RF,F)
73960 END
73970 ELSE ENSLINE:=TRUE
73980 END
73990 ELSE ENSLINE:=FALSE;
74000 END;
74010 (**)
74020 (**)
74030 (*-02()
74040 BEGIN (*OF A68*)
74050 END; (*OF A68*)
74060 ()-02*)
74070 (*+01()
74080 BEGIN (*OF MAIN PROGRAM*)
74090 END (* OF EVERYTHING *).
74100 ()+01*)

13
lang/a68s/liba68s/entier.c Normal file
View file

@ -0,0 +1,13 @@
int ENTIER(statlink, a)
int *statlink ;
register double a ;
{
int n ;
n = ( int ) a ;
return( n < 0 && ( double ) n != a ? n - 1 : n ) ;
}
int ROUN(statlink,a)
int *statlink ;
register double a ;
{ return(ENTIER(statlink, a+0.5)) ;
}

650
lang/a68s/liba68s/errorr.p Normal file
View file

@ -0,0 +1,650 @@
01000 #include "rundecs.h"
01010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
01020 (**)
01030 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN;
01040 (*+05() FUNCTION TIME: REAL; EXTERN; ()+05*)
01050 PROCEDURE ABORT; EXTERN;
01060 PROCEDURE ACLOSE(EFET: FETROOMP); EXTERN;
01070 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
01080 (**)
01090 (**)
01100 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP; EXTERN;
01110 FUNCTION GETPROC(RN: OBJECTP): ASNAKED; EXTERN;
01120 (*+02() FUNCTION GETLINENO :INTEGER; EXTERN; ()+02*)
01130 (**)
01140 (**)
01150 PROCEDURE ERRORR(N :INTEGER); FORWARD;
01160 (**)
01170 (**)
01180 FUNCTION RELSUP(REF: OBJECTP): UNDRESSP;
01190 (*FINDS THE TRUE POINTER TO A REFERENCE VALUE*)
01200 BEGIN
01210 WITH REF^ DO
01220 CASE SORT OF
01230 REFSL1:
01240 RELSUP := INCPTR(ANCESTOR, OFFSET);
01250 REFSLN, UNDEF:
01260 ERRORR(IDREL);
01270 REF1, REF2, REFN, RECN, REFR, RECR, NILL:
01280 RELSUP := ASPTR(ORD(REF));
01290 CREF:
01300 RELSUP := IPTR;
01310 END;
01320 IF FPTST(REF^) THEN GARBAGE(REF)
01330 END;
01340 (**)
01350 (**)
01360 PROCEDURE ERRORR (*N: INTEGER*);
01370 TYPE BYTES = PACKED ARRAY [1..BYTESWIDTH] OF CHAR ;
01380 VAR RANGE: PRANGE;
01390 CURR: IPOINT;
01400 XCASE: 0..15;
01410 IDP: PIDBLK;
01420 RP,RQ : RECORD CASE SEVERAL OF
01430 1: ( PP : OBJECTPP ) ;
01440 2: ( PI : ^ INTEGER ) ;
01450 3: ( PR : ^ REAL ) ;
01460 4: ( PB : ^ BYTES ) ;
01470 5: ( PD : ^ INTEGER ) ;
01480 0 , 6 , 7 , 8 , 9 , 10 : () ;
01490 END ;
01500 INT: INTEGER ;
01510 POINT: OBJECTP ;
01520 PI1: ^INTEGER ;
01530 RANGECOUNT :INTEGER ; DECPOINT :OFFSETRANGE ; COUNT :INTEGER ;
01540 LOOPTYP : INTEGER ;
01550 THISWAS68: BOOLEAN ;
01560 PFET: FETROOMP;
01570 (*+02() LOCALRANGE :BOOLEAN ; ()+02*)
01580 (*+54() EXCEPT: UNDRESSP; IB: IPOINT; RG: PRANGE; ()+54*)
01590 PROCEDURE PRINTREAL(X: REAL);
01600 VAR RTG: REALTEGER;
01610 BEGIN WITH RTG DO
01620 BEGIN
01630 REA := X;
01640 IF (INT=INTUNDEF) (*+05()OR (INT2=INTUNDEF)()+05*) THEN WRITE(OUTPUT, ' UNDEFINED')
01650 ELSE WRITE(OUTPUT, X);
01660 END
01670 END;
01680 PROCEDURE PRINTSINGLE(II :INTEGER);
01690 (*+01()
01700 VAR RTG: PACKED RECORD CASE SEVERAL OF
01710 1: ( INT : INTEGER ) ;
01720 2: ( REA : REAL ) ;
01730 3: ( SIGN : BOOLEAN ; EXP : 0..3777B ; MANT : 0..7777777777777777B )
01740 END ;
01750 BEGIN WITH RTG DO
01760 BEGIN
01770 INT := II;
01780 IF II=INTUNDEF THEN WRITE('UNDEFINED')
01790 ELSE IF EXP=ORD(SIGN)*3777B THEN
01800 BEGIN WRITE(II:1);
01810 IF (II<64) AND (II>=0) THEN WRITE(' (', CHR(II), ')');
01820 END
01830 ELSE WRITE(REA)
01840 END
01850 END;
01860 ()+01*)
01870 (*+02()
01880 BEGIN
01890 IF II = INTUNDEF THEN WRITE( OUTPUT , 'UNDEFINED' )
01900 ELSE
01910 BEGIN
01920 WRITE( OUTPUT , II : 1 ) ;
01930 IF ( II >= 32 ) AND ( II < 128 ) THEN WRITE( OUTPUT , ' (' , CHR( II ) , ')' )
01940 END
01950 END ;
01960 ()+02*)
01970 (*+05()
01980 BEGIN
01990 IF II = INTUNDEF THEN WRITE( OUTPUT , 'UNDEFINED' )
02000 ELSE
02010 BEGIN
02020 WRITE( OUTPUT , II : 1 ) ;
02030 IF ( II >= 32 ) AND ( II < 128 ) THEN WRITE( OUTPUT , ' (' , CHR( II ) , ')' )
02040 END
02050 END ;
02060 ()+05*)
02070 PROCEDURE PRINTDOUBLE( LV : A68LONG ) ;
02080 (*+01()
02090 BEGIN
02100 END ;
02110 ()+01*)
02120 (*+05()
02130 BEGIN
02140 PRINTREAL(LV);
02150 END ;
02160 ()+05*)
02170 (*+02()
02180 (*+12()
02190 BEGIN
02200 PRINTREAL(LV);
02210 END ;
02220 ()+12*)
02230 (*+13()
02240 BEGIN
02250 PRINTREAL(LV);
02260 END;
02270 ()+13*)
02280 ()+02*)
02290 PROCEDURE PRINTVAL(ANOBJECT :OBJECTP);FORWARD;
02300 PROCEDURE PRINTBIGD(ANOBJECT :OBJECTP; TEMPLATE :DPOINT; OFF :INTEGER);
02310 VAR I, J :INTEGER;
02320 PROCEDURE PRINTD(ANOBJECT :OBJECTP; TEMPLATE :DPOINT);
02330 LABEL 9;
02340 VAR TEMPOS, I :INTEGER;
02350 BEGIN
02360 RQ.PI := INCPTR(ANOBJECT, OFF) ;
02370 WITH RQ DO
02380 IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
02390 IF ORD(TEMPLATE)=0 THEN (*DRESSED*)
02400 IF PP ^ ^.SORT IN [REF1,REF2,CREF,REFSL1] THEN
02410 WRITE(OUTPUT , 'REF #', ORD( RELSUP(PP ^) ):(*-01()1()-01*)(*+01()6 OCT()+01*) )
02420 ELSE PRINTVAL(PP ^)
02430 (*-01() ELSE IF ORD(TEMPLATE)>SZINT THEN PRINTDOUBLE(PR^) ()-01*)
02440 ELSE PRINTSINGLE( PI ^ )
02450 ELSE (*PART OF STRUCT*)
02460 BEGIN
02470 TEMPOS := 1;
02480 WHILE TEMPLATE^[TEMPOS]>=0 DO
02490 BEGIN
02500 IF TEMPLATE^[TEMPOS]=OFF THEN
02510 BEGIN
02520 IF PP ^ ^.SORT IN [REF1,CREF,REFSL1] THEN
02530 WRITE(OUTPUT , 'REF #', ORD( RELSUP(PP ^) ):(*-01()1()-01*)(*+01()6 OCT()+01*) )
02540 ELSE PRINTVAL(PP ^);
02550 OFF := OFF+SZADDR;
02560 GOTO 9
02570 END;
02580 TEMPOS := TEMPOS+1
02590 END;
02600 INT := ORD( PI^ ) ;
02610 IF INT = INTUNDEF THEN
02620 BEGIN
02630 WRITE( OUTPUT , 'UNDEFINED' ) ;
02640 OFF := OFF + SZINT
02650 END
02660 ELSE CASE TEMPLATE^[TEMPOS+1+J] OF
02670 0: (*NO ACTION*);
02680 1: BEGIN WRITE( OUTPUT , PI ^ : 1 ); OFF := OFF+SZINT END;
02690 3: BEGIN WRITE( OUTPUT , PR ^ ); OFF := OFF+SZREAL END;
02700 5: BEGIN
02710 PRINTREAL(PR^); WRITE(OUTPUT, ' I'); OFF := OFF+SZREAL;
02720 PR := INCPTR(ANOBJECT, OFF);
02730 PRINTREAL(PR^);
02740 OFF := OFF+SZREAL;
02750 END;
02760 7: BEGIN WRITE(OUTPUT , '"', CHR( PI ^ ) , '"'); OFF := OFF+SZINT END;
02770 9: BEGIN
02780 (*+01() IF PI^<0 THEN ()+01*)
02790 (*-01() IF PI^<>0 THEN ()-01*)
02800 WRITE(OUTPUT , '.TRUE') ELSE WRITE(OUTPUT , '.FALSE'); OFF := OFF+SZINT
02810 END;
02820 10: BEGIN WRITE( OUTPUT , PI ^ : (*-01()1()-01*)(*+01()20 OCT()+01*) ); OFF := OFF+SZINT END;
02830 11: BEGIN
02840 (*+05() RQ.PI := ASPTR( ORD( PI ) * 2 ) ; ()+05*)
02850 WRITE( OUTPUT , '"', (*+05()RQ.()+05*)PB ^ , '"') ;
02860 OFF := OFF + SZINT
02870 END ;
02880 12: BEGIN WRITE( OUTPUT , 'PROC'); OFF := OFF+1; OFF := OFF+SZADDR END;
02890 END;
02900 9: J := J+1;
02910 END
02920 END;
02930 BEGIN (* OF PRINTBIGD *)
02940 J := 0; I := OFF;
02950 IF ORD(TEMPLATE)>MAXSIZE THEN (*COMPLETE STRUCT*)
02960 BEGIN WRITE( OUTPUT , '(');
02970 WHILE OFF-I<TEMPLATE^[0] DO
02980 BEGIN IF J<>0 THEN WRITE( OUTPUT , ', '); PRINTD(ANOBJECT, TEMPLATE) END;
02990 WRITE( OUTPUT , ')')
03000 END
03010 ELSE PRINTD(ANOBJECT, TEMPLATE)
03020 END;
03030 PROCEDURE PRINTVAL;
03040 VAR I, K :INTEGER;
03050 ELEMENTS :OBJECTP;
03060 BEGIN (*OF PRINTVAL*)
03070 WITH ANOBJECT^ DO
03080 CASE SORT OF
03090 STRING:
03100 BEGIN
03110 WRITE( OUTPUT , ' STRING "');
03120 FOR I := 1 TO STRLENGTH DO WRITE( OUTPUT , CHARVEC[I]);
03130 WRITE( OUTPUT , '"')
03140 END;
03150 ROUTINE:
03160 BEGIN WRITE( OUTPUT , ' PROC ');
03170 WRITE( OUTPUT , PROCBL^.ROUTNAME.ALF, ' ', ENVCHAIN:(*-01()1()-01*)(*+01()6 OCT()+01*) ) END;
03180 STRUCT:
03190 BEGIN WRITE( OUTPUT , ' STRUCT');
03200 PRINTBIGD(INCPTR(ANOBJECT, STRUCTCONST), DBLOCK, 0)
03210 END;
03220 COVER:
03230 BEGIN
03240 IF (OPENED IN STATUS) AND NOT ASSOC THEN
03250 BEGIN
03260 ACLOSE(BOOK);
03270 IF NOT(STARTUP IN STATUS) THEN BEGIN PFET := BOOK;
03280 DISPOSE(PFET) END;
03290 STATUS := STATUS-[OPENED];
03300 END;
03310 WRITE( OUTPUT , ' (', POFCPOS:1, ',', LOFCPOS:1, ',', COFCPOS:1, ')');
03320 END;
03330 REF1:
03340 PRINTSINGLE(VALUE);
03350 (*-01() REF2:
03360 PRINTDOUBLE( LONGVALUE ) ; ()-01*)
03370 REFSL1:
03380 PRINTBIGD(ANCESTOR^.PVALUE, DBLOCK, OFFSET);
03390 CREF:
03400 PRINTSINGLE(IPTR^.FIRSTWORD);
03410 RECN, REFN:
03420 WRITE( OUTPUT , ' REF #', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO STRUCT');
03430 REFR, RECR:
03440 WRITE( OUTPUT , ' REF #', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ARRAY');
03450 REFSLN:
03460 WRITE( OUTPUT , ' REF TO SLICE');
03470 NILL:
03480 WRITE( OUTPUT , ' NIL');
03490 UNDEF:
03500 WRITE( OUTPUT , ' UNDEFINED');
03510 END;
03520 END; (* OF PRINTVAL *)
03530 PROCEDURE PRINTMULT(ANOBJECT:OBJECTP);
03540 VAR I, K :INTEGER;
03550 ELEMENTS:OBJECTP;
03560 BEGIN
03570 WITH ANOBJECT^ DO
03580 BEGIN
03590 IF SORT<>REFSLN THEN BEGIN WRITE( OUTPUT , ' ARRAY '); ELEMENTS := PVALUE END
03600 ELSE BEGIN WRITE( OUTPUT , ' SLICE '); ELEMENTS := ANCESTOR^.PVALUE END;
03610 WRITE( OUTPUT , '[');
03620 FOR I := ROWS DOWNTO 0 DO WITH DESCVEC[I] DO
03630 BEGIN WRITE( OUTPUT , LI:1, ':', UI:1); IF I>0 THEN WRITE( OUTPUT , ', ') END;
03640 WRITE( OUTPUT , ']');
03650 IF ROWS=0 THEN (*1 DIMENSION ONLY*) WITH DESCVEC[0] DO
03660 BEGIN
03670 FOR I := LI TO LI+2 DO IF I<=UI THEN
03680 BEGIN WRITELN( OUTPUT ) ; WRITE( OUTPUT , ' ');
03690 PRINTBIGD(INCPTR(ELEMENTS, DI*I-LBADJ), MDBLOCK, 0) END;
03700 IF UI-LI>5 THEN
03710 BEGIN WRITELN( OUTPUT ); WRITE( OUTPUT , ' ...'); K := UI-2 END
03720 ELSE K := LI + 3 ;
03730 FOR I := K TO UI DO
03740 BEGIN WRITELN( OUTPUT ); WRITE( OUTPUT , ' ');
03750 PRINTBIGD(INCPTR(ELEMENTS, DI*I-LBADJ), MDBLOCK, 0) END
03760 END
03770 END
03780 END;
03790 BEGIN (*OF ERROR*)
03800 (*+02()LOCALRANGE := TRUE;()+02*)
03810 CURR := DYNAMIC(ME);
03820 (*+54()
03830 IB := CURR;
03840 REPEAT
03850 SETMYSTATIC(IB);
03860 IF ISA68(IB) THEN
03870 BEGIN
03880 RG := FIRSTRG.RIBOFFSET;
03890 WHILE (RG^.FIRSTW.TRACESAVE=NIL) AND (RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET) DO
03900 RG := RG^.RIBOFFSET;
03910 END;
03920 IB := DYNAMIC(IB);
03930 UNTIL (SCOPE=1) OR (RG^.FIRSTW.TRACESAVE<>NIL);
03940 WITH RG^ DO
03950 IF (FIRSTW.TRACESAVE<>NIL) AND (N<>0) THEN
03960 BEGIN
03970 SETMYSTATIC(CURR);
03980 EXCEPT := INCPTR(CRSTRUCT(EXCEPTDB), STRUCTCONST);
03990 EXCEPT^.FIRSTWORD := N;
04000 CL68(GETPROC(FIRSTW.TRACESAVE), INCPTR(EXCEPT, -STRUCTCONST));
04010 END;
04020 ()+54*)
04030 WRITELN( OUTPUT );
04040 WRITELN( OUTPUT , ' RUN-TIME ERROR');
04050 WRITE( OUTPUT , ' ');
04060 IF (N>56) OR (N<0) THEN WRITE( OUTPUT , (*+54()'USER DEFINED ',()+54*) 'ERROR NO. ', N:1)
04070 ELSE
04080 CASE N OF
04090 (*+05()
04100 -16,-15,-14,-13,-12,-11,-10,-9,-8,-7,-6,-5,-4,-3,-2,-1: (* SYSTEM INTERRUPTS *)
04110 WRITE( OUTPUT , 'SIGNAL NUMBER ' , -N:1 ) ;
04120 ()+05*)
04130 0: (*NO FURTHER ACTION*);
04140 1: (*RASSIG*)
04150 WRITE( OUTPUT , 'ASSIGNATION TO UNDEFINED NAME');
04160 2: (*RSEL*)
04170 WRITE( OUTPUT , 'SELECTION FROM UNDEFINED STRUCTURE');
04180 3: (*RDEREF*)
04190 WRITE( OUTPUT , 'DEREFERENCING UNDEFINED NAME');
04200 4: (*RASSIGNIL*)
04210 WRITE( OUTPUT , 'ASSIGNATION TO .NIL');
04220 5: (*RSELNIL*)
04230 WRITE( OUTPUT , 'SELECTION FROM .NIL');
04240 6: (*RDEREFNIL*)
04250 WRITE( OUTPUT , 'DEREFERENCING .NIL');
04260 7: (*IDREL*)
04270 WRITE( OUTPUT , 'IDENTITY-RELATION INVOLVING UNDEFINED NAME, OR NAME OF SLICE');
04280 8: (*RPOWNEG*)
04290 WRITE( OUTPUT , 'RAISING AN .INT TO A -VE POWER');
04300 9: (*RBYTESPACK*)
04310 WRITE( OUTPUT , 'BYTESPACK ON .STRING LONGER THAN BYTES WIDTH');
04320 13: (*RCLOWER*)
04330 WRITE( OUTPUT , 'UNDEFINED LOWER-BOUND IN ACTUAL-DECLARER');
04340 14: (*RCUPPER*)
04350 WRITE( OUTPUT , 'UNDEFINED UPPER-BOUND IN ACTUAL-DECLARER');
04360 15: (*RLWUPB*)
04370 WRITE( OUTPUT , 'LEFT OPERAND OF .LWB OR .UPB OUT OF RANGE');
04380 16: (*RSL1ERROR*)
04390 WRITE( OUTPUT , 'SUBSCRIPT (OR LOWER-BOUND) TOO LOW');
04400 17: (*RSL2ERROR*)
04410 WRITE( OUTPUT , 'SUBSCRIPT (OR UPPER-BOUND) TOO HIGH');
04420 18: (*RSLICE*)
04430 WRITE( OUTPUT , 'SLICE FROM UNDEFINED ARRAY');
04440 19: (*RSLICENIL*)
04450 WRITE( OUTPUT , 'SLICE FROM .NIL');
04460 20: (*RMULASS*)
04470 WRITE( OUTPUT , 'BOUNDS MISMATCH IN ASSIGNATION OF ARRAY');
04480 21: (*RROUTN*)
04490 WRITE( OUTPUT , 'CALL OF UNDEFINED ROUTINE');
04500 22: (*RCHARERROR*)
04510 WRITE( OUTPUT , 'PRINTING NON-EXISTENT .CHAR');
04520 23: (*RSCOPE*)
04530 WRITE( OUTPUT , 'SCOPE VIOLATION');
04540 24: (*RARG*)
04550 WRITE( OUTPUT , 'ARGUMENT OF ZERO IS IMPOSSIBLE');
04560 RDUMMY:
04570 WRITE( OUTPUT , 'FEATURE NOT IMPLEMENTED YET');
04580 NOREAD,NOWRITE,NOBIN,NORESET,NOSET,NOESTAB:
04590 WRITE( OUTPUT , 'IMPOSSIBLE TRANSPUT OPERATION');
04600 NOTOPEN:
04610 WRITE( OUTPUT , 'FILE NOT OPEN');
04620 NOPHYSICAL:
04630 WRITE( OUTPUT , 'PHYSICAL END OF FILE REACHED');
04640 NOLOGICAL:
04650 WRITE( OUTPUT , 'LOGICAL END OF FILE REACHED');
04660 NOMOOD:
04670 WRITE( OUTPUT , 'NOT KNOWN WHETHER READING OR WRITING');
04680 POSMIN:
04690 WRITE( OUTPUT , '(P,L,C) < (1,1,1)');
04700 POSMAX:
04710 WRITE( OUTPUT , '(P,L,C) > PHYSICAL FILE SIZE');
04720 SMALLLINE:
04730 WRITE( OUTPUT , 'LINE TOO SHORT FOR VALUE');
04740 WRONGCHAR:
04750 WRITE( OUTPUT , 'UNACCEPTABLE CHARACTER READ');
04760 NODIGIT:
04770 WRITE( OUTPUT , 'DIGIT EXPECTED');
04780 WRONGVAL:
04790 WRITE( OUTPUT , 'VALUE OUT OF RANGE');
04800 WRONGMULT:
04810 WRITE( OUTPUT , 'LOWER BOUND OF ASSOCIATED ARRAY /= 1');
04820 NOALTER,NOSHIFT:
04830 WRITE( OUTPUT , 'ILLEGAL CHANGE TO/FROM BINARY TRANSPUT');
04840 END;
04850 WRITE( OUTPUT , ', DETECTED IN ');
04860 THISWAS68 := FALSE ;
04870 REPEAT
04880 SETMYSTATIC(CURR);
04890 IF ISA68(CURR) THEN
04900 BEGIN
04910 THISWAS68 := TRUE ;
04920 (*+02()IF LOCALRANGE THEN
04930 BEGIN
04940 WRITE(OUTPUT, 'LINE ', GETLINENO:1);
04950 LOCALRANGE := FALSE;
04960 END
04970 ELSE ()+02*)
04980 WRITE( OUTPUT , 'LINE ', LINENO:1);
04990 IF SCOPE<>1 THEN
05000 WRITELN( OUTPUT ,' OF PROCEDURE ', PROCBL^.ROUTNAME.ALF)
05010 ELSE WRITELN( OUTPUT , ' OF MAIN PROGRAM');
05020 RANGE := FIRSTRG.RIBOFFSET; RANGECOUNT := 0;
05030 REPEAT WITH RANGE^ DO
05040 WITH FIRSTW , RP DO
05050 BEGIN
05060 WRITELN( OUTPUT );
05070 IF RIBOFFSET<>FIRSTRG.RIBOFFSET THEN
05080 BEGIN WRITE( OUTPUT , ' RANGE ', RANGECOUNT:2); IDP := RGIDBLK;
05090 (*-41() PP := INCPTR ( RANGE , RGCONST ) ; ()-41*)
05100 (*+41() PP := ASPTR ( ORD( RANGE ) ) ; ()+41*)
05110 END
05120 ELSE IF SCOPE<>1 THEN
05130 BEGIN WRITE( OUTPUT , ' PARAMETERS'); IDP := RGIDBLK;
05140 (*-41() PP :=ASPTR(CURR-PARAMOFFSET-PROCBL^.PARAMS) ()-41*)
05150 (*+41() PP :=ASPTR((*+02()ARGBASE()+02*)(CURR)-PARAMOFFSET+PROCBL^.PARAMS) ()+41*)
05160 END
05170 ELSE IDP := NIL;
05180 IF IDP<>NIL THEN
05190 BEGIN
05200 RANGECOUNT := RANGECOUNT-1;
05210 (*-41() WHILE ORD ( PP ) < ORD ( RGNEXTFREE ) DO ()-41*)
05220 (*+41() WHILE ORD ( PP ) > ORD ( RGLASTUSED ) DO ()+41*)
05230 BEGIN
05240 IDP := INCPTR(IDP, -SZIDBLOCK);
05250 WITH IDP ^ DO
05260 BEGIN
05270 (*+41()
05280 IF IDSIZE <> 0 THEN
05290 PP := INCPTR( PP , - IDSIZE )
05300 ELSE
05310 PP := INCPTR( PP , - SZADDR ) ;
05320 ()+41*)
05330 WRITELN( OUTPUT ); WRITE( OUTPUT , ' ', ALF);
05340 IF XMODE>=16 THEN
05350 BEGIN WRITE( OUTPUT , ' LOC'); XCASE := XMODE-16 END
05360 ELSE BEGIN WRITE( OUTPUT , ' '); XCASE := XMODE END;
05370 INT := ORD (PI^) ;
05380 IF INT=INTUNDEF THEN WRITE( OUTPUT , ' UNDEFINED')
05390 ELSE CASE XCASE OF
05400 0: (*REF*)
05410 WITH PP ^ ^ DO
05420 CASE SORT OF
05430 REF1, REF2, CREF, REFSL1:
05440 BEGIN
05450 WRITE( OUTPUT , ' REF #', ORD(RELSUP(PP ^)):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05460 PRINTVAL(PP ^)
05470 END;
05480 RECN, REFN:
05490 BEGIN
05500 WRITE( OUTPUT , ' REF #', ORD(PP ^):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05510 PRINTVAL(PVALUE)
05520 END;
05530 RECR, REFR:
05540 BEGIN
05550 WRITE( OUTPUT , ' REF #', ORD(PP ^):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05560 PRINTMULT(PP ^)
05570 END;
05580 REFSLN:
05590 BEGIN WRITE( OUTPUT , ' REF TO '); PRINTMULT(PP ^) END;
05600 NILL:
05610 WRITE( OUTPUT , ' REF NIL');
05620 UNDEF:
05630 WRITE( OUTPUT , ' REF UNDEFINED');
05640 END;
05650 1: (*INT*)
05660 WRITE( OUTPUT , ' INT ', PI ^ :1);
05670 3: (*REAL*)
05680 WRITE( OUTPUT , ' REAL ', PR ^ );
05690 5: (*COMPL*)
05700 BEGIN
05710 IF XMODE>=16 THEN POINT := PP ^ ^.PVALUE ELSE POINT := PP ^ ;
05720 WITH POINT ^ DO
05730 BEGIN WRITE(OUTPUT, ' COMPL '); PRINTREAL(RE); WRITE(OUTPUT, ' I'); PRINTREAL(IM); END
05740 END;
05750 7: (*CHAR*)
05760 WRITE( OUTPUT , ' CHAR "', CHR( PI ^ ) , '"');
05770 8: (*STRING*)
05780 IF PP^=UNDEFIN THEN WRITE( OUTPUT , ' STRING ""')
05790 ELSE PRINTVAL(PP^);
05800 9: (*BOOL*)
05810 (*+01() IF PI^<0 THEN ()+01*)
05820 (*-01() IF PI^<>0 THEN ()-01*)
05830 WRITE( OUTPUT , ' BOOL .TRUE') ELSE WRITE( OUTPUT , ' BOOL .FALSE');
05840 10: (*BITS*)
05850 WRITE( OUTPUT , ' BITS ', PI ^ : (*-01()1()-01*)(*+01()20 OCT()+01*) );
05860 11: (*BYTES*)
05870 BEGIN
05880 (*+05() RQ.PI := ASPTR( ORD( PI ) * 2 ) ; ()+05*)
05890 WRITE( OUTPUT , ' BYTES "', (*+05()RQ.()+05*)PB ^ , '"' )
05900 END ;
05910 12: (*PROC*)
05920 PRINTVAL(PP ^);
05930 13: (*STRUCT*)
05940 BEGIN IF XMODE>=16 THEN POINT := PP ^ ^.PVALUE ELSE POINT := PP ^ ; PRINTVAL(POINT) END;
05950 14: (*ROW*)
05960 PRINTMULT(PP ^);
05970 END ;
05980 (*-41()
05990 IF IDSIZE<>0 THEN
06000 PP := INCPTR ( PP , IDSIZE )
06010 ELSE
06020 PP := INCPTR ( PP , SZADDR )
06030 ()-41*)
06040 END
06050 END;
06060 END;
06070 IF (RIBOFFSET=FIRSTRG.RIBOFFSET) AND (SCOPE <> 1) THEN (*PARAMS*)
06080 PP:=(*+41() ASPTR(ORD(RANGE)) ()+41*)
06090 (*-41() INCPTR(RANGE,RGCONST) ()-41*)
06100 ELSE
06110 PP := (*+41() INCPTR(RGLASTUSED, -SZINT ); ()+41*)
06120 (*-41() ASPTR(ORD(RGNEXTFREE)) ; ()-41*)
06130 LOOPTYP := PD^ ;
06140 FOR COUNT := 1 TO LOOPCOUNT DO
06150 BEGIN
06160 WRITELN( OUTPUT ) ;
06170 CASE LOOPTYP OF
06180 1: BEGIN
06190 PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06200 WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06210 PI1 := INCPTR( PI , STACKSZINT ) ;
06220 WRITELN( OUTPUT , '.BY ', PI1 ^ :1);
06230 PI1 := INCPTR( PI , 3 * STACKSZINT ) ;
06240 WRITE ( OUTPUT , '.TO ', PI1 ^ :1);
06250 PD := INCPTR( PD , 4 * STACKSZINT )
06260 END;
06270 2: BEGIN
06280 PI1 := INCPTR( PI , STACKSZINT ) ;
06290 WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06300 PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06310 WRITE ( OUTPUT , '.TO ', PI1 ^ :1);
06320 PD := INCPTR( PD , 3 * STACKSZINT )
06330 END;
06340 3: BEGIN
06350 PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06360 WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06370 PI1 := INCPTR( PI , STACKSZINT ) ;
06380 WRITE ( OUTPUT , '.BY ', PI1 ^ :1);
06390 PD := INCPTR( PD , 3 * STACKSZINT )
06400 END;
06410 4: BEGIN
06420 PI1 := INCPTR( PI , STACKSZINT ) ;
06430 WRITE ( OUTPUT , '.FOR ', PI1 ^ :1);
06440 PD := INCPTR( PD , 2 * STACKSZINT )
06450 END
06460 END;
06470 LOOPTYP := PD^
06480 END;
06490 RANGE := RIBOFFSET;
06500 WRITELN( OUTPUT )
06510 END
06520 UNTIL RANGE=FIRSTRG.RIBOFFSET;
06530 WRITELN( OUTPUT );
06540 WRITE( OUTPUT , ' WHICH WAS CALLED FROM ')
06550 END
06560 ELSE THISWAS68 := FALSE ;
06570 CURR := DYNAMIC(CURR);
06580 UNTIL (SCOPE=1) AND THISWAS68 ;
06590 WRITELN( OUTPUT , 'STANDARD-PRELUDE');
06600 (*+01()
06610 WRITELN(' CPU ', (CPUCLOCK+CLOCK)/1000:6:3);
06620 MESSAGE(' RUN ABORTED');
06630 ()+01*)
06640 (*+05()
06650 WRITELN(ERROR, ' RUN ABORTED');
06660 WRITELN(ERROR, ' CPU ', TIME :5:2);
06670 ()+05*)
06680 ABORT
06690 END;
06700 (**)
06710 (**)
06720 (*+01()
06730 PROCEDURE PDERR(VAR A: INTEGER; J,K,L,M: INTEGER; N: BOOLEAN;
06740 VAR F: TEXT; VAR MSG: MESS);
06750 (*TO CATCH NOS- AND PASCAL-DETECTED ERRORS*)
06760 VAR I: INTEGER;
06770 BEGIN
06780 SETMYSTATIC(DYNAMIC(ME));
06790 WRITELN(F);
06800 I := 1;
06810 REPEAT
06820 WRITE(F, MSG[I]); I := I+1
06830 UNTIL ORD(MSG[I])=0;
06840 WRITELN(F);
06850 ERRORR(0);
06860 END;
06870 ()+01*)
06880 (**)
06890 (**)
06900 (*+54()
06910 PROCEDURE OFFERROR;
06920 VAR CURR, IB: IPOINT; RG: PRANGE;
06930 BEGIN
06940 CURR := STATIC(ME);
06950 IB := CURR;
06960 REPEAT
06970 SETMYSTATIC(IB);
06980 IF ISA68(IB) THEN
06990 BEGIN
07000 RG := FIRSTRG.RIBOFFSET;
07010 WHILE (RG^.FIRSTW.TRACESAVE=NIL) AND (RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET) DO
07020 RG := RG^.RIBOFFSET;
07030 END;
07040 IB := DYNAMIC(IB);
07050 UNTIL (SCOPE=1) OR (RG^.FIRSTW.TRACESAVE<>NIL);
07060 WITH RG^.FIRSTW DO WITH TRACESAVE ^ DO
07070 IF TRACESAVE<>NIL THEN
07080 BEGIN
07090 FDEC; IF FTST THEN GARBAGE(TRACESAVE);
07100 TRACESAVE := NIL;
07110 END;
07120 SETMYSTATIC(CURR);
07130 END;
07140 (**)
07150 (**)
07160 PROCEDURE ONERROR(R: OBJECTP);
07170 VAR LOCRG: DEPTHRANGE;
07180 RG: PRANGE;
07190 BEGIN
07200 LOCRG := 0;
07210 RG := FIRSTRG.RIBOFFSET;
07220 WHILE RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET DO
07230 BEGIN RG := RG^.RIBOFFSET; LOCRG := LOCRG+1 END;
07240 IF SCOPE+LOCRG<R^.OSCOPE THEN ERRORR(RSCOPE);
07250 WITH FIRSTRG.RIBOFFSET^ DO
07260 BEGIN
07270 IF FIRSTW.TRACESAVE<>NIL THEN WITH FIRSTW.TRACESAVE^ DO
07280 BEGIN FDEC; IF FTST THEN GARBAGE(FIRSTW.TRACESAVE) END;
07290 FIRSTW.TRACESAVE := R;
07300 FPINC(R^);
07310 END;
07320 END;
07330 (**)
07340 (**)
07350 FUNCTION MAKEXCE(N: INTEGER): OBJECTP;
07360 VAR NEWSTRUCT: UNDRESSP;
07370 BEGIN
07380 NEWSTRUCT := INCPTR(CRSTRUCT(EXCEPTDB), STRUCTCONST);
07390 NEWSTRUCT^.FIRSTWORD := N;
07400 MAKEXCE := INCPTR(NEWSTRUCT, -STRUCTCONST);
07410 END;
07420 (**)
07430 (**)
07440 ()+54*)
07450 (*-02() BEGIN END ; ()-02*)
07460 (*+01()
07470 BEGIN (*OF MAIN PROGRAM*)
07480 END (*OF EVERYTHING*).
07490 ()+01*)

14
lang/a68s/liba68s/exit.c Normal file
View file

@ -0,0 +1,14 @@
#include <stdio.h>
cleenup()
{
register FILE *iop ;
extern FILE *_lastbuf ;
for ( iop = _iob ; iop < _lastbuf ; iop ++ )
fclose( iop ) ;
}
exit(n)
int n;
{ cleenup() ; _exit(n) ; }

4
lang/a68s/liba68s/exp.c Normal file
View file

@ -0,0 +1,4 @@
extern double _exp();
double EXP(statlink, x)
int *statlink; double x;
{return(_exp(x));}

40
lang/a68s/liba68s/fixed.p Normal file
View file

@ -0,0 +1,40 @@
74200 #include "rundecs.h"
74210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
74220 (**)
74230 (**)
74240 FUNCTION SUBFIXED(SIGN, BEFORE, POINT, AFTER : INTEGER; VAR EXP: INTEGER; EXPNEEDED: BOOLEAN;
74250 X: REALTEGER; R: BOOLEAN; VAR S: OBJECTP; START: INTEGER): BOOLEAN; EXTERN;
74260 PROCEDURE ERRORFILL(VAR S: OBJECTP; LENGTH: INTEGER); EXTERN;
74270 (**)
74280 (**)
74290 FUNCTION FIXED(XMODE: INTEGER; VAL: REALTEGER; WIDTH, AFTER: INTEGER): OBJECTP;
74300 VAR
74310 S: OBJECTP;
74320 SIGN, ABSWIDTH, BEFORE, POINT, E: INTEGER;
74330 OK: BOOLEAN;
74340 BEGIN
74350 ABSWIDTH := ABS(WIDTH);
74360 SIGN := ORD((WIDTH>0) OR (VAL.INT<0));
74370 IF ABSWIDTH-AFTER=1 THEN
74380 IF (WIDTH<0) AND (VAL.INT<0) THEN AFTER := AFTER-1;
74390 S := NIL;
74400 REPEAT
74410 POINT := ORD(AFTER>0);
74420 BEFORE := ABSWIDTH-SIGN-POINT-AFTER-ORD(WIDTH=0); (*-VE FOR WIDTH=0*)
74430 IF (WIDTH<>0) AND (BEFORE<0) THEN AFTER := -1; (*WILL CAUSE SUBFIXED TO FAIL*)
74440 OK := SUBFIXED(SIGN, BEFORE, POINT, AFTER, E, FALSE, VAL, XMODE=2, S, 1);
74450 AFTER := AFTER-1
74460 UNTIL OK OR (AFTER<0);
74470 IF NOT OK THEN ERRORFILL(S, ABSWIDTH+ORD(WIDTH=0));
74480 FIXED := S;
74490 END;
74500 (**)
74510 (**)
74520 (*-02()
74530 BEGIN (*OF A68*)
74540 END; (*OF A68*)
74550 ()-02*)
74560 (*+01()
74570 BEGIN (*OF MAIN PROGRAM*)
74580 END (* OF EVERYTHING *).
74590 ()+01*)

48
lang/a68s/liba68s/float.p Normal file
View file

@ -0,0 +1,48 @@
74700 #include "rundecs.h"
74710 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
74720 (**)
74730 (**)
74740 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN ;
74750 FUNCTION SUBFIXED(SIGN, BEFORE, POINT, AFTER : INTEGER; VAR EXP: INTEGER; EXPNEEDED: BOOLEAN;
74760 X: REALTEGER; R: BOOLEAN; VAR S: OBJECTP; START: INTEGER): BOOLEAN; EXTERN;
74770 PROCEDURE ERRORFILL(VAR S: OBJECTP; LENGTH: INTEGER); EXTERN;
74780 (**)
74790 (**)
74800 FUNCTION FLOAT(XMODE: INTEGER; VAL: REALTEGER; WIDTH, AFTER, EXP: INTEGER): OBJECTP;
74810 VAR E: REALTEGER;
74820 S: OBJECTP;
74830 ABSWIDTH, BEFORE, POINT, ABSEXP, EXPSIGN: INTEGER;
74840 OK, OK1: BOOLEAN;
74850 BEGIN
74860 ABSWIDTH := ABS(WIDTH)+ORD(WIDTH=0);
74870 ABSEXP := ABS(EXP)+ORD(EXP=0);
74880 S := CRSTRING(ABSWIDTH);
74890 REPEAT
74900 POINT := ORD(AFTER>0);
74910 BEFORE := ABSWIDTH-1-POINT-AFTER-1-ABSEXP;
74920 IF BEFORE<0 THEN AFTER := -1; (*WILL CAUSE SUBFIXED TO FAIL*)
74930 OK := SUBFIXED(ORD((WIDTH>0) OR (VAL.INT<0))-ORD((WIDTH<0) AND (VAL.INT>=0)),
74940 BEFORE, POINT, AFTER, E.INT, TRUE, VAL, XMODE=2, S, 1)
74950 AND (BEFORE+AFTER>0);
74960 S^.CHARVEC[1+BEFORE+POINT+AFTER+1] := 'E';
74970 EXPSIGN := ORD((EXP>0) OR (E.INT<0));
74980 OK1 := SUBFIXED(EXPSIGN, ABSEXP-EXPSIGN, 0, 0, E.INT, FALSE, E, FALSE,
74990 S, 1+BEFORE+POINT+AFTER+2);
75000 AFTER := AFTER-ORD(AFTER<>0); ABSEXP := ABSEXP+1
75010 UNTIL NOT OK OR OK1;
75020 IF NOT OK THEN ERRORFILL(S, ABSWIDTH);
75030 FLOAT := S;
75040 END;
75050 (**)
75060 (**)
75070 (*+01() (*$X4*) ()+01*)
75080 (**)
75090 (**)
75100 (*-02()
75110 BEGIN (*OF A68*)
75120 END; (*OF A68*)
75130 ()-02*)
75140 (*+01()
75150 BEGIN (*OF MAIN PROGRAM*)
75160 END (* OF EVERYTHING *).
75170 ()+01*)

113
lang/a68s/liba68s/genrec.p Normal file
View file

@ -0,0 +1,113 @@
30100 #include "rundecs.h"
30110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
30120 (**)
30130 (**)
30140 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP; EXTERN;
30150 FUNCTION HEAPMUL(NEWMULT: OBJECTP; TEMPLATE: DPOINT): OBJECTP; EXTERN;
30160 PROCEDURE COPYSLICE(ASLICE: OBJECTP); EXTERN;
30170 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
30180 (**)
30190 (**)
30200 FUNCTION RECCMN (THEREC: OBJECTP; LOCRG: DEPTHRANGE): OBJECTP;
30210 (*COMMON FOR CREATING RECURSIVE OBJECTS*)
30220 VAR TEMPREC: OBJECTP;
30230 CUTOP: PRANGE;
30240 BEGIN
30250 CUTOP := FIRSTRG.RIBOFFSET;
30260 WITH CUTOP^ DO WITH FIRSTW DO
30270 BEGIN
30280 TEMPREC := RECGEN;
30290 RECGEN := THEREC;
30300 END;
30310 WITH THEREC^ DO
30320 BEGIN
30330 OSCOPE := SCOPE+LOCRG;
30340 NEXT:= TEMPREC;
30350 PREV := INCPTR(CUTOP, RECOFFSET-NEXTOFFSET);
30360 END;
30370 IF TEMPREC <> NIL THEN TEMPREC^.PREV:= THEREC;
30380 RECCMN:= THEREC;
30390 END;
30400 (**)
30410 (**)
30420 FUNCTION CRRECN(ANOBJECT:OBJECTP):OBJECTP;
30430 (* PCREATEREF+1 *)
30440 VAR NEWRECN:OBJECTP;
30450 BEGIN
30460 ENEW(NEWRECN,RECNSIZE);
30470 WITH NEWRECN^ DO
30480 BEGIN
30490 (*-02() FIRSTWORD := SORTSHIFT * ORD(RECN); ()-02*)
30500 (*+02() PCOUNT:=0; SORT:=RECN; ()+02*)
30510 (*+01() SECONDWORD := 0; ()+01*)
30520 PVALUE:=ANOBJECT;
30530 WITH PVALUE^ DO FINC;
30540 ANCESTOR := NEWRECN;
30550 OFFSET := STRUCTCONST;
30560 CRRECN:=RECCMN(NEWRECN,FIRSTRG.RIBOFFSET^.RGSCOPE)
30570 END
30580 END;
30590 (**)
30600 (**)
30610 FUNCTION GENRMUL(NEWMULT: OBJECTP; TEMPLATE: DPOINT; LOCRG: DEPTHRANGE): OBJECTP;
30620 (*PLEAPGEN+5*)
30630 VAR NEWRECR: OBJECTP;
30640 BEGIN
30650 NEWRECR := HEAPMUL(NEWMULT, TEMPLATE);
30660 NEWRECR^.SORT := RECR;
30670 GENRMUL := RECCMN(NEWRECR, LOCRG)
30680 END;
30690 (**)
30700 (**)
30710 FUNCTION GENRSTR (TEMPLATE: DPOINT; LOCRG: DEPTHRANGE): OBJECTP;
30720 (*PLEAPGEN+2*)
30730 VAR NEWRECN: OBJECTP;
30740 BEGIN
30750 ENEW(NEWRECN, RECNSIZE);
30760 WITH NEWRECN^ DO
30770 BEGIN
30780 (*-02() FIRSTWORD := SORTSHIFT * ORD(RECN); ()-02*)
30790 (*+02() PCOUNT:=0; SORT:=RECN; ()+02*)
30800 (*+01() SECONDWORD := 0; ()+01*)
30810 PVALUE := CRSTRUCT(TEMPLATE);
30820 ANCESTOR := NEWRECN;
30830 OFFSET := STRUCTCONST;
30840 WITH PVALUE^ DO FINC
30850 END;
30860 GENRSTR := RECCMN(NEWRECN, LOCRG)
30870 END;
30880 (**)
30890 (**)
30900 FUNCTION CRRECR(ANOBJECT: OBJECTP): OBJECTP;
30910 (*PCREATEREF+3*)
30920 VAR NEWREC: OBJECTP;
30930 BEGIN
30940 WITH ANOBJECT^ DO
30950 BEGIN
30960 IF (BPTR<>NIL) AND (SORT=MULT) THEN (*SOURCE IS A SLICE*)
30970 COPYSLICE(ANOBJECT);
30980 IF FTST THEN
30990 BEGIN
31000 NEWREC :=ANOBJECT;
31010 NEWREC^.SORT := RECR;
31020 END
31030 ELSE
31040 BEGIN
31050 NEWREC := COPYDESC(ANOBJECT,MULT);
31060 WITH NEWREC^.PVALUE^ DO FINC
31070 END
31080 END;
31090 WITH NEWREC^ DO
31100 BEGIN
31110 ANCESTOR := NEWREC;
31120 CCOUNT := 1;
31130 CRRECR := RECCMN(NEWREC, FIRSTRG.RIBOFFSET^.RGSCOPE);
31140 END
31150 END;
31160 (**)
31170 (**)
31180 (*-02() BEGIN END ; ()-02*)
31190 (*+01()
31200 BEGIN (*OF MAIN PROGRAM*)
31210 END (*OF EVERYTHING*).
31220 ()+01*)

58
lang/a68s/liba68s/get.e Normal file
View file

@ -0,0 +1,58 @@
#include "e.h"
exa _1GETT ; 1st label in GETT (run68d)
exp $GET
exp $READ
exp $GETT
exp $STANDINC
ina jumpdesc
jumpdesc
con 0I SZADDR,0I SZADDR,0I SZADDR ; enough space for 3 pointers
pro $GET,GETTVARSPACE
mes 11
loc GETSTAMP
stl -SZWORD ; set up frame stamp
lxa 0 ; load argument base
lol SZADDR+SZADDR ; load length of data lost, skip static link & space
loc SZADDR+SZADDR+SZWORD
adu SZWORD ; add on space for static link & file pointer & count
ads SZWORD ; add argument base and offset
loi SZADDR ; load file address, objectp
SFL SZADDR ; store in space, left for this reason
lor 1 ; fill in jump info with SP
SFE jumpdesc+SZADDR
lxl 0 ; and LB
SFE jumpdesc+SZADDR+SZADDR
LFE _1GETT-ENTRYOFFSET ; and code entry point
SFE jumpdesc
gto jumpdesc ; jump to GETT, in run68d
end GETTVARSPACE
pro $READ,GETTVARSPACE
mes 11
loc GETSTAMP
stl -SZWORD ; set up frame stamp
LFE .HTOP-STINOFFSET ; address of stout in global frame
SFL SZADDR ; store in first param after static link
lor 1 ; fill in jump info with SP
SFE jumpdesc+SZADDR
lxl 0 ; and LB
SFE jumpdesc+SZADDR+SZADDR
LFE _1GETT-ENTRYOFFSET ; and code entry point
SFE jumpdesc
gto jumpdesc ; jump to GETT, in run68d
end GETTVARSPACE
pro $STANDINC,SZWORD ; call to stinch (run68d)
loc PASCALSTAMP
stl -SZWORD
LFL SZADDR+SZADDR ; param 1, pcov
LFL SZADDR ; param 2, lfn
LFL 0 ; static link
cal $STINCH
asp SZADDR+SZADDR+SZADDR
ret 0
end SZWORD

18
lang/a68s/liba68s/getaddr.e Normal file
View file

@ -0,0 +1,18 @@
#define SZWORD EM_WSIZE
#define SZADDR EM_PSIZE
#if SZWORD==SZADDR
#define LOAD lol
#define STORE stl
#else
#define LOAD ldl
#define STORE sdl
#endif
mes 2,SZWORD,SZADDR
exp $GETADDRE
pro $GETADDRE,0
LOAD SZADDR ; load param (adress of variable) (1st after static link)
ret SZADDR ; return address
end 0

40
lang/a68s/liba68s/getmult.p Normal file
View file

@ -0,0 +1,40 @@
31300 #include "rundecs.h"
31310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
31320 (**)
31330 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
31340 (**)
31350 (**)
31360 FUNCTION GETMULT(NEWMULT: OBJECTP): OBJECTP;
31370 VAR OLDMULT:OBJECTP;
31380 BEGIN
31390 WITH NEWMULT^ DO
31400 BEGIN
31410 OLDMULT := PVALUE;
31420 SORT := MULT;
31430 OSCOPE := 0;
31440 PVALUE := OLDMULT^.PVALUE;
31450 IF ( OLDMULT^.SORT <> MULT ) OR ( OLDMULT^.BPTR = NIL ) THEN
31460 BEGIN
31470 WITH PVALUE^ DO
31480 IF CCOUNT<>0 THEN CCOUNT := CCOUNT+1;
31490 (*CCOUNT=0 TREATED AS INFINITY*)
31500 OLDMULT := PVALUE;
31510 END;
31520 BPTR := OLDMULT;
31530 FPTR := OLDMULT^.IHEAD;
31540 IHEAD := NIL;
31550 IF FPTR <> NIL THEN FPTR^.BPTR := NEWMULT
31560 ELSE FPINC(OLDMULT^);
31570 OLDMULT^.IHEAD := NEWMULT;
31580 FPINC(PVALUE^);
31590 END;
31600 IF FPTST(OLDMULT^) THEN GARBAGE(OLDMULT);
31610 GETMULT := NEWMULT;
31620 END;
31630 (**)
31640 (**)
31650 (*-02() BEGIN END ; ()-02*)
31660 (*+01()
31670 BEGIN (*OF MAIN PROGRAM*)
31680 END (*OF EVERYTHING*).
31690 ()+01*)

181
lang/a68s/liba68s/getout.p Normal file
View file

@ -0,0 +1,181 @@
31800 #include "rundecs.h"
31810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
31820 (**)
31830 (**)
31840 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
31850 PROCEDURE RANGEXT; EXTERN;
31860 (**)
31870 (**)
31880 PROCEDURE DORECGEN;
31890 VAR RECGEN, RECPOINT: OBJECTP;
31900 BEGIN
31910 RECGEN := FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN;
31920 WHILE RECGEN<>NIL DO WITH RECGEN^ DO
31930 BEGIN
31940 FINC;
31950 WITH PVALUE^ DO FDEC;
31960 IF FPTST(PVALUE^) THEN GARBAGE(PVALUE);
31970 PVALUE := UNDEFIN;
31980 RECPOINT := RECGEN; RECGEN := NEXT;
31990 WITH RECPOINT^ DO BEGIN FDEC; IF FTST THEN GARBAGE(RECPOINT) END
32000 END
32010 END;
32020 (**)
32030 (**)
32040 FUNCTION GETOUT(TARGETRN: DEPTHRANGE; TARGETLEB: OFFSETRANGE; MAP: BITMAP; LOOPS: INTEGER): ASNAKED;
32050 (*PGETOUT - EXIT FROM ROUTINES UNTIL TARGET IS REACHED.
32060 MAP IS THE STACK TO BE LEFT STANDING*)
32070 VAR CURR, NECLEV, IB: IPOINT;
32080 BITP: BITMAP;
32090 PTR: OBJECTPP;
32100 I: INTEGER;
32110 XMODE: INTEGER; IBTYPE: (A68, PUT, GET, OTHER);
32120 PVAL: OBJECTP;
32130 TEMPOINT: RECORD CASE SEVERAL OF
32140 0: (POINT: INTPOINT);
32150 1: (PPOINT: OBJECTPP);
32160 2,3,4,5,6,7,8,9,10: ();
32170 END;
32180 TEMP: NAKEGER;
32190 BEGIN
32200 CURR := STATIC(ME);
32210 REPEAT
32220 NECLEV := (*-05()STATIC( CURR )()-05*)(*+05()STATICP+192()+05*) ;
32230 WHILE (*-41()(NECLEV>CURR) AND (NECLEV<ME)()-41*)(*+41()(NECLEV<CURR) AND (NECLEV>ME)()+41*) DO
32240 (*BYPASS ANY STATIC LEVELS CREATED BY SETNSTATIC*)
32250 (*-05() NECLEV:=STATIC(NECLEV) ; ()-05*)
32260 (*+05() BEGIN SETMYSTATIC( NECLEV ) ; NECLEV := STATICP+192 END ; ()+05*)
32270 REPEAT
32280 REPEAT
32290 IF ISA68(CURR) THEN
32300 BEGIN
32310 IBTYPE := A68;
32320 BITP := BITPATTERN;
32330 END
32340 ELSE
32350 BEGIN BITP.COUNT := 0; BITP.MASK := 0;
32360 IF ISPUT(CURR) THEN IBTYPE := PUT
32370 ELSE IF ISGET(CURR) THEN IBTYPE := GET
32380 ELSE IBTYPE := OTHER;
32390 END;
32400 (*-02() IB := CURR; ()-02*)
32410 (*+02() IB := ARGBASE(CURR); ()+02*)
32420 PTR := ASPTR(IB);
32430 CURR := DYNAMIC(CURR);
32440 SETMYSTATIC(CURR);
32450 WITH BITP DO
32460 BEGIN
32470 IF (CURR=NECLEV) AND (LEVEL=TARGETRN) THEN (*THIS IS TARGET ROUTINE*)
32480 BEGIN
32490 COUNT := COUNT-MAP.COUNT;
32500 FOR I := 1 TO MAP.COUNT DIV SZWORD DO MASK := MASK*2
32510 END;
32520 IF MASK<>0 THEN
32530 BEGIN
32540 PTR := INCPTR( PTR, (*-41()- ()-41*)COUNT - PARAMOFFSET ) ;
32550 FOR I := 1 TO COUNT DIV SZWORD DO
32560 BEGIN
32570 (*+41() PTR := INCPTR(PTR, -SZWORD); ()+41*)
32580 IF MASK<0 THEN IF FPTST(PTR^^) THEN GARBAGE(PTR^);
32590 (*-41() PTR := INCPTR(PTR, SZWORD); ()-41*)
32600 MASK := MASK*2
32610 END
32620 END
32630 ELSE IF IBTYPE IN [PUT, GET] THEN WITH TEMPOINT DO (*DESTROY DATA LIST OF PUT OR GET*)
32640 BEGIN
32650 POINT := ASPTR(IB-DLOFFSET); BITP.COUNT := POINT^;
32660 POINT := INCPTR(POINT, (*-41()-()-41*) BITP.COUNT);
32670 WHILE ORD(POINT) (*-41()<()-41*)(*+41()>()+41*) IB-DLOFFSET DO
32680 BEGIN
32690 XMODE := POINT^;
32700 (*-41() POINT := INCPTR(POINT, SZWORD); ()-41*)
32710 IF IBTYPE=PUT THEN
32720 BEGIN
32730 CASE XMODE OF
32740 4,7,11,12,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31:
32750 BEGIN
32760 (*+41() POINT := INCPTR(POINT, -SZADDR); ()+41*)
32770 PVAL := PPOINT^;
32780 (*-41() POINT := INCPTR(POINT, SZADDR); ()-41*)
32790 WITH PVAL^ DO
32800 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
32810 END;
32820 (*+61() 1,3,5: POINT := INCPTR(POINT, (*+41()-()+41*) SZLONG); ()+61*)
32830 14: POINT := INCPTR(POINT, (*+41()-()+41*) SZPROC);
32840 2: POINT := INCPTR(POINT, (*+41()-()+41*) SZREAL);
32850 0,6,8,9,10: POINT := INCPTR(POINT, (*+41()-()+41*) SZINT);
32860 -1: (*NO ACTION*);
32870 END;
32880 END
32890 ELSE
32900 IF XMODE IN [0..13,15..31] THEN
32910 BEGIN
32920 (*+41() POINT := INCPTR(POINT, -SZADDR); ()+41*)
32930 PVAL := PPOINT^;
32940 (*-41() POINT := INCPTR(POINT, SZADDR); ()-41*)
32950 WITH PVAL^ DO
32960 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
32970 END
32980 ELSE IF XMODE=14 THEN POINT := INCPTR(POINT, (*+41()-()+41*) SZPROC);
32990 (*+41() POINT := INCPTR(POINT, -SZWORD); ()+41*)
33000 END;
33010 (*-01()
33020 POINT := INCPTR(POINT, (*-41()+SZWORD()-41*)(*+41()-SZADDR()+41*));
33030 PVAL := PPOINT^; (*PVAL = THE .REF.FILE PARAMETER OF PUT/GET*)
33040 WITH PVAL^ DO
33050 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
33060 ()-01*)
33070 END
33080 END
33090 UNTIL ISA68(CURR);
33100 IF (CURR=NECLEV) AND (LEVEL=TARGETRN) THEN (*THIS IS TARGET ROUTINE*)
33110 WHILE ORD(FIRSTRG.RIBOFFSET)-CURR (*-41()>()-41*)(*+41()< -()+41*) TARGETLEB DO
33120 BEGIN RANGEXT; IF FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN<>NIL THEN DORECGEN END
33130 ELSE BEGIN
33140 WHILE FIRSTRG.RIBOFFSET^.RIBOFFSET<>FIRSTRG.RIBOFFSET DO
33150 BEGIN RANGEXT; IF FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN<>NIL THEN DORECGEN END;
33160 RANGEXT; (*FOR PARAMETERS RANGE*)
33170 END;
33180 UNTIL CURR=NECLEV
33190 UNTIL LEVEL=TARGETRN;
33200 FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := LOOPS;
33210 (*+01() TEMP.ASNAK := 0; ()+01*)
33220 IF IBTYPE IN [PUT, GET] THEN
33230 TEMP.NAK.STOWEDVAL :=
33240 ASPTR(IB (*-41()(*-01()-SZADDR()-01*)-()-41*)(*+41()+SZWORD+SZADDR+()+41*) BITP.COUNT-DLOFFSET)
33250 ELSE
33260 TEMP.NAK.STOWEDVAL := ASPTR(IB (*-41()-()-41*)(*+41()+()+41*) BITP.COUNT-PARAMOFFSET);
33270 TEMP.NAK.POINTER := ASPTR(CURR);
33280 GETOUT := TEMP.ASNAK;
33290 END;
33300 (**)
33310 (**)
33320 PROCEDURE GBSTK(BITP: BITMAP);
33330 (*PGBSTK*)
33340 VAR PTR: OBJECTP;
33350 I: INTEGER;
33360 BEGIN WITH BITP DO
33370 BEGIN
33380 IF MASK<>0 THEN
33390 BEGIN
33400 I := COUNT;
33410 WHILE I>0 DO
33420 BEGIN
33430 I := I-SZWORD;
33440 IF MASK<0 THEN
33450 BEGIN PTR := ASPTR(GETSTKTOP(SZADDR, I)); IF FPTST(PTR^) THEN GARBAGE(PTR) END;
33460 MASK := MASK*2
33470 END
33480 END;
33490 END
33500 END;
33510 (**)
33520 (**)
33530 (*-02()
33540 BEGIN
33550 END ;
33560 ()-02*)
33570 (*+01()
33580 BEGIN (*OF MAIN PROGRAM*)
33590 END (*OF EVERYTHING*).
33600 ()+01*)

397
lang/a68s/liba68s/gett.p Normal file
View file

@ -0,0 +1,397 @@
75200 #include "rundecs.h"
75210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
75220 (**)
75230 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN ;
75240 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
75250 PROCEDURE FORMPDESC(OLDESC: OBJECTP; VAR PDESC1: PDESC); EXTERN ;
75260 FUNCTION NEXTEL(I: INTEGER; VAR PDESC1: PDESC): BOOLEAN; EXTERN ;
75270 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
75280 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
75290 PROCEDURE TESTCC (TARGET: OBJECTP); EXTERN ;
75300 PROCEDURE TESTSS (REFSTRUCT: OBJECTP); EXTERN ;
75310 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN ;
75320 FUNCTION GETPROC(RN: OBJECTP): ASNAKED; EXTERN ;
75330 PROCEDURE CLPASC1(P1: IPOINT; PROC: ASPROC); EXTERN;
75340 PROCEDURE CLRDSTR(PCOV: OBJECTP; VAR CHARS: GETBUFTYPE; TERM (*+01() , TERM1 ()+01*) : TERMSET;
75350 VAR I: INTEGER; BOOK: FETROOMP; PROC: ASPROC); EXTERN;
75360 FUNCTION FUNC68(PB: ASNAKED; RF: OBJECTP): BOOLEAN; EXTERN;
75370 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
75380 PROCEDURE ENSSTATE(RF:OBJECTP;VAR F:OBJECTP;READING:STATUSSET); EXTERN;
75390 FUNCTION ENSPAGE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
75400 FUNCTION ENSLINE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
75410 (**)
75420 (**)
75430 PROCEDURE GETT(RF: OBJECTP);
75440 (*+02() LABEL 1; ()+02*)
75450 VAR COUNT, XMODE, XSIZE, SIZE, I, J: INTEGER;
75460 Q:INTPOINT;
75470 PVAL,F:OBJECTP;
75480 P: UNDRESSP;
75490 TEMP: REALTEGER;
75500 TEMPLATE:DPOINT;
75510 WASSTRING:BOOLEAN;
75520 BUFFER:RECORD CASE SEVERAL OF
75530 1: (CHARS: GETBUFTYPE);
75540 2: (INTS :ARRAY [1..20] OF INTEGER);
75550 0, 3, 4, 5, 6, 7, 8, 9, 10: () ;
75560 END;
75570 PDESC1: PDESC;
75580 (**)
75590 (*+02() PROCEDURE DUMMYG; (*JUST HERE TO MAKE 1 GLOBAL, NOT CALLED*)
75600 BEGIN GOTO 1 END; ()+02*)
75610 (**)
75620 PROCEDURE SKIPSPACES(RF:OBJECTP;VAR F:OBJECTP);
75630 (*SKIP INITIAL SPACES,++ENSSPOSN OF NEXT NON SPACE CHAR++*)
75640 VAR CA:CHAR;
75650 I: INTEGER;
75660 BEGIN
75670 REPEAT
75680 IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
75690 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(NOLOGICAL);
75700 I := 0;
75710 WITH F^ DO
75720 CLRDSTR(PCOVER, BUFFER.CHARS, ALLCHAR-[' '] (*+01() , ALLCHAR1 ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS)
75730 UNTIL NOT(LINEOVERFLOW IN F^.PCOVER^.STATUS)
75740 END; (*SKIPSPACES*)
75750 (**)
75760 PROCEDURE VALUEREAD(RF:OBJECTP;VAR F:OBJECTP);
75770 (*+01() LABEL 111,222,77; ()+01*)
75780 VAR PTR: UNDRESSP;
75790 C,CC:CHAR;
75800 CARRYON, ISEEN: BOOLEAN;
75810 I,J,K:INTEGER;
75820 OLD:STATUSSET;
75830 PROCEDURE READNUM;
75840 CONST MAXINTDIV10 = (*+11() 28147497671065 ()+11*) (*+12() 3276 ()+12*) (*+13() 214748364 ()+13*) ;
75850 MAXINTMOD10 = (*+11() 5 ()+11*) (*+12() 7 ()+12*) (*+13() 7 ()+13*) ;
75860 VAR PM, DIGITS, I, VALDIG: INTEGER;
75870 NEG: BOOLEAN;
75880 BEGIN WITH F^, TEMP, BUFFER DO
75890 BEGIN
75900 PM := 0;
75910 CLRDSTR(PCOVER,CHARS,ALLCHAR-['+','-'] (*+01() , ALLCHAR1 ()+01*) ,PM,PCOVER^.BOOK,PCOVER^.DOGETS);
75920 NEG := (PM=1) AND (CHARS[0]='-');
75930 I := 0;
75940 CLRDSTR(PCOVER,CHARS,ALLCHAR-[' '] (*+01() , ALLCHAR1 ()+01*) ,I,PCOVER^.BOOK,PCOVER^.DOGETS);
75950 DIGITS := 0;
75960 CLRDSTR(PCOVER,CHARS,ALLCHAR-['0'..'9'] (*+01() , ALLCHAR1 ()+01*) ,DIGITS,PCOVER^.BOOK,PCOVER^.DOGETS);
75970 IF (PM>1) OR (DIGITS=0) THEN ERRORR(NODIGIT);
75980 INT := 0;
75990 FOR I := 0 TO DIGITS-1 DO
76000 BEGIN
76010 VALDIG := ORD( CHARS[I] ) - ORD( '0' ) ;
76020 IF ( INT > MAXINTDIV10 ) OR ( ( INT = MAXINTDIV10 ) AND ( VALDIG > MAXINTMOD10 ) ) THEN
76030 ERRORR( WRONGVAL ) ;
76040 INT := INT * 10 + VALDIG
76050 END;
76060 IF NEG THEN INT := - INT
76070 END
76080 END;
76090 (**)
76100 PROCEDURE READREAL;
76110 (*+01()
76120 CONST TML=10000000000000000B;
76130 LIMIT=14631463146314631B; (*16*TML/10*)
76140 ()+01*)
76150 VAR RINT: MINT ;
76160 PM, BEFORE, AFTER, E, I, RINTEXP: INTEGER;
76170 NEG: BOOLEAN;
76180 BEGIN WITH F^, TEMP, BUFFER DO
76190 BEGIN
76200 PM := 0;
76210 CLRDSTR(PCOVER,CHARS,ALLCHAR-['+','-'] (*+01() , ALLCHAR1 ()+01*) ,PM,PCOVER^.BOOK,PCOVER^.DOGETS);
76220 NEG := (PM=1) AND (CHARS[0]='-');
76230 I := 0;
76240 CLRDSTR(PCOVER,CHARS,ALLCHAR-[' '] (*+01() , ALLCHAR1 ()+01*) ,I,PCOVER^.BOOK,PCOVER^.DOGETS);
76250 BEFORE := 0; AFTER := 0; E := 0;
76260 CLRDSTR(PCOVER,CHARS,ALLCHAR-['0'..'9'] (*+01() , ALLCHAR1 ()+01*) ,BEFORE,PCOVER^.BOOK,PCOVER^.DOGETS);
76270 RINT := 0;
76280 FOR I := 0 TO BEFORE-1 DO
76290 (*+01() IF RINT<LIMIT THEN ()+01*)
76300 RINT := RINT*10+(ORD(CHARS[I])-ORD('0'))
76310 (*+01() ELSE E := E+1 ()+01*) ;
76320 I := 0;
76330 CLRDSTR(PCOVER,CHARS,ALLCHAR-['.','E'(*-50(),CHR(ORD('E')+32)()-50*)](*+01(),ALLCHAR1()+01*),
76340 I,PCOVER^.BOOK,PCOVER^.DOGETS);
76350 IF (I>0) AND (CHARS[0]='.') THEN
76360 BEGIN
76370 CLRDSTR (
76380 PCOVER,CHARS,ALLCHAR-['0'..'9'] (*+01() , ALLCHAR1 ()+01*) ,AFTER,PCOVER^.BOOK,PCOVER^.DOGETS
76390 ) ;
76400 FOR I := 0 TO AFTER-1 DO
76410 (*+01() IF RINT<LIMIT THEN ()+01*)
76420 RINT := RINT*10+(ORD(CHARS[I])-ORD('0'))
76430 (*+01() ELSE E := E+1 ()+01*) ;
76440 RINTEXP := BEFORE + AFTER - E ;
76450 I := 0;
76460 CLRDSTR(PCOVER,CHARS,ALLCHAR-['E'(*-50(),CHR(ORD('E')+32)()-50*)](*+01(),ALLCHAR1()+01*),
76470 I,PCOVER^.BOOK,PCOVER^.DOGETS);
76480 IF (PM>1) OR (AFTER=0) THEN ERRORR(NODIGIT);
76490 E := E-AFTER;
76500 END
76510 ELSE IF (PM>1) OR (BEFORE=0) THEN ERRORR(NODIGIT);
76520 IF (I>0) AND ((CHARS[0]='E') (*-50()OR (CHARS[0]=CHR(ORD('E')+32))()-50*)) THEN
76530 BEGIN
76540 I := 0;
76550 CLRDSTR(PCOVER,CHARS,ALLCHAR-[' '] (*+01() , ALLCHAR1 ()+01*) ,I,PCOVER^.BOOK,PCOVER^.DOGETS);
76560 READNUM;
76570 E := E+INT;
76580 END;
76590 IF ( E + RINTEXP <= MINREALEXP ) OR ( RINT = 0 ) THEN REA := 0.0
76600 ELSE IF E>=323 THEN ERRORR(WRONGVAL)
76610 ELSE
76620 BEGIN
76630 (*-02() REA := TIMESTEN(RINT, E); ()-02*)
76640 (*+02() REA := TIMESTE(RINT, E); ()+02*)
76650 IF INT=INTUNDEF THEN ERRORR(WRONGVAL);
76660 END;
76670 IF NEG THEN REA := -REA;
76680 END
76690 END;
76700 (**)
76710 BEGIN WITH TEMP DO
76720 BEGIN
76730 IF NOT([OPENED,READMOOD,CHARMOOD]<=F^.PCOVER^.STATUS) THEN
76740 ENSSTATE(RF, F, [OPENED,READMOOD,CHARMOOD]);
76750 XSIZE := SZINT;
76760 CASE XMODE OF
76770 -1: (*FILLER*) XSIZE := 0;
76780 (*+61() 1,3,5: (*LONG MODES*)
76790 BEGIN XSIZE := SZLONG; DUMMY END; ()+61*)
76800 0: (*INT*)
76810 BEGIN SKIPSPACES(RF,F); READNUM; P^.FIRSTINT := INT END;
76820 2: (*REAL*)
76830 BEGIN XSIZE := SZREAL; SKIPSPACES(RF,F); READREAL; P^.FIRSTREAL := REA END;
76840 4: (*COMPL*)
76850 BEGIN
76860 XSIZE := SZADDR;
76870 SKIPSPACES(RF,F);
76880 READREAL;
76890 P^.FIRSTREAL := REA;
76900 I := 0;
76910 WITH F^ DO
76920 CLRDSTR (
76930 PCOVER,BUFFER.CHARS,ALLCHAR-[' ','I'] (*+01() , ALLCHAR1 ()+01*) ,I,PCOVER^.BOOK,PCOVER^.DOGETS
76940 ) ;
76950 ISEEN := FALSE;
76960 FOR K := 0 TO I-1 DO
76970 ISEEN := ISEEN OR (BUFFER.CHARS[K]='I');
76980 IF NOT ISEEN THEN ERRORR(WRONGCHAR);
76990 READREAL;
77000 P := INCPTR(P, SZREAL);
77010 P^.FIRSTREAL := REA;
77020 END;
77030 6: (*CHAR*)
77040 BEGIN IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
77050 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(NOLOGICAL);
77060 I := -1;
77070 WITH F^ DO
77080 CLRDSTR(PCOVER, BUFFER.CHARS, ALLCHAR (*+01() , ALLCHAR ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS);
77090 P^.FIRSTWORD := I
77100 END;
77110 7: (*STRING*)
77120 WITH BUFFER DO
77130 BEGIN
77140 XSIZE := SZADDR;
77150 I:=0;
77160 REPEAT
77170 IF [PAGEOVERFLOW]<=F^.PCOVER^.STATUS
77180 THEN CARRYON:=ENSPAGE(RF,F)
77190 ELSE CARRYON:=TRUE;
77200 IF CARRYON THEN
77210 IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
77220 THEN BEGIN OLD:=F^.PCOVER^.STATUS;
77230 IF F^.LINEMENDED=UNDEFIN THEN CARRYON := FALSE
77240 ELSE CARRYON:=FUNC68(GETPROC(F^.LINEMENDED),RF);
77250 ENSSTATE(RF,F,OLD)
77260 END
77270 ELSE
77280 WITH F^ DO
77290 BEGIN
77300 CLRDSTR(PCOVER, CHARS, TERM (*+01() , TERM1 ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS);
77310 CARRYON := LINEOVERFLOW IN PCOVER^.STATUS
77320 END
77330 UNTIL NOT CARRYON;
77340 WITH P^ DO
77350 BEGIN FPDEC(FIRSTPTR^);
77360 IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
77370 FIRSTPTR:=CRSTRING(I);
77380 FPINC(FIRSTPTR^);
77390 PTR := INCPTR(FIRSTPTR, STRINGCONST);
77400 END;
77410 WHILE I <> (I DIV CHARPERWORD) * CHARPERWORD DO
77420 BEGIN CHARS[I]:=CHR(0);
77430 I:=I+1
77440 END;
77450 J:=I DIV CHARPERWORD ;
77460 FOR I:=1 TO J DO
77470 BEGIN PTR^.FIRSTWORD := INTS[I]; PTR := INCPTR(PTR, SZWORD) END;
77480 END; (*STRING*)
77490 8: (*BOOL*)
77500 BEGIN IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
77510 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(NOLOGICAL);
77520 I := -1;
77530 WITH F^ DO
77540 CLRDSTR(PCOVER, BUFFER.CHARS, ALLCHAR (*+01() , ALLCHAR ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS);
77550 IF CHR(I)='T' THEN INT := TRUEVAL
77560 ELSE IF CHR(I)='F' THEN INT := 0
77570 ELSE ERRORR(WRONGCHAR) ;
77580 P^.FIRSTWORD := INT
77590 END; (*BOOL*)
77600 9: (*BITS*)
77610 BEGIN K:=0;
77620 FOR J:=1 TO BITSWIDTH DO
77630 BEGIN SKIPSPACES(RF,F);
77640 I := -1;
77650 WITH F^ DO
77660 CLRDSTR(PCOVER, BUFFER.CHARS, ALLCHAR (*+01() , ALLCHAR ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS);
77670 IF CHR(I) IN ['T','F'] THEN K := K*2+ORD(CHR(I)='T')
77680 ELSE ERRORR(WRONGCHAR)
77690 END;
77700 P^.FIRSTWORD := K
77710 END;
77720 10: (*BYTES*)
77730 FOR J:=1 TO BYTESWIDTH DO
77740 BEGIN
77750 IF LINEOVERFLOW IN F^.PCOVER^.STATUS THEN
77760 IF NOT ENSLINE(RF, F) THEN ERRORR(NOLOGICAL);
77770 I := -1;
77780 WITH F^ DO
77790 CLRDSTR(PCOVER, BUFFER.CHARS, ALLCHAR (*+01() , ALLCHAR ()+01*) , I, PCOVER^.BOOK, PCOVER^.DOGETS);
77800 ALF[J] := CHR(I);
77810 P^.FIRSTWORD := INT
77820 END;
77830 11: (*PROC*)
77840 CL68(GETPROC(PVAL), RF);
77850 12: (*STRUCT*)
77860 BEGIN J:=0;
77870 REPEAT J:=J+1 UNTIL TEMPLATE^[J]<0;
77880 I:=ORD(P);
77890 WHILE ORD(P)-I<TEMPLATE^[0] DO
77900 BEGIN J:=J+1;
77910 XMODE:=TEMPLATE^[J]-1;
77920 VALUEREAD(RF,F);
77930 P:=INCPTR(P, XSIZE)
77940 END;
77950 XMODE:=12;
77960 END; (*STRUCT*)
77970 14: (*CODE(REF FILE)VOID*)
77980 CLPASC1( ORD(RF), PROCC );
77990 END; (*CASE*)
78000 END (*WITH*)
78010 END; (*VALUEREAD*)
78020 (**)
78030 BEGIN (*GET*)
78040 (*+02() 1: ()+02*) COUNT := GETSTKTOP(SZWORD, 0);
78050 FPINC(RF^);
78060 J := COUNT+SZWORD; WHILE J>SZWORD DO
78070 BEGIN
78080 J := J-SZWORD;
78090 XMODE := GETSTKTOP(SZWORD, J);
78100 IF XMODE IN [0..13,15..31] THEN
78110 BEGIN
78120 J := J - SZADDR;
78130 PVAL := ASPTR(GETSTKTOP(SZADDR, J));
78140 FPINC(PVAL^);
78150 END
78160 ELSE IF XMODE=14 THEN J := J-SZPROC
78170 END;
78180 TESTF(RF,F);
78190 J := COUNT+SZWORD; WHILE J>SZWORD DO
78200 BEGIN
78210 J := J-SZWORD;
78220 XMODE:=GETSTKTOP(SZWORD, J);
78230 IF XMODE>=16 THEN (*ROW*)
78240 BEGIN XMODE:=XMODE-16;
78250 J := J-SZADDR;
78260 PVAL:=ASPTR(GETSTKTOP(SZADDR, J));
78270 WITH PVAL^ DO
78280 BEGIN
78290 IF FPTWO(ANCESTOR^.PVALUE^) THEN
78300 TESTCC(PVAL);
78310 FORMPDESC(PVAL,PDESC1);
78320 TEMPLATE:=MDBLOCK;
78330 WITH ANCESTOR^ DO
78340 BEGIN
78350 IF ORD(TEMPLATE)=0 THEN SIZE:=1
78360 ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN SIZE:=ORD(TEMPLATE)
78370 ELSE SIZE:=TEMPLATE^[0];
78380 WHILE NEXTEL(0,PDESC1) DO WITH PDESC1 DO WITH PDESCVEC[0] DO
78390 BEGIN I:=PP;
78400 WHILE I<PP+PSIZE DO
78410 BEGIN
78420 P:=INCPTR(PVALUE, I);
78430 VALUEREAD(RF,F); I:=I+SIZE
78440 END
78450 END
78460 END
78470 END
78480 END
78490 ELSE IF XMODE>=0 THEN
78500 BEGIN WASSTRING:=FALSE;
78510 IF XMODE = 14 THEN
78520 BEGIN
78530 J := J - SZPROC ;
78540 TEMP.PROCC := GETSTKTOP( SZPROC , J )
78550 END
78560 ELSE
78570 BEGIN
78580 J := J - SZADDR ;
78590 PVAL:=ASPTR(GETSTKTOP(SZADDR, J));
78600 IF XMODE <> 11 THEN WITH PVAL^ DO
78610 IF SORT IN [RECN, REFN] THEN
78620 IF XMODE<>7 THEN (*NOT STRING*)
78630 BEGIN
78640 TEMPLATE:=PVALUE^.DBLOCK;
78650 IF FPTWO(PVALUE^) THEN
78660 TESTSS(PVAL);
78670 P := INCPTR(PVALUE, STRUCTCONST)
78680 END
78690 ELSE
78700 BEGIN ENEW(P,1); P^.FIRSTPTR:=PVALUE;WASSTRING:=TRUE END
78710 ELSE
78720 BEGIN
78730 TEMPLATE := DBLOCK;
78740 WITH ANCESTOR^ DO
78750 IF FPTWO(PVALUE^) THEN
78760 P := SAFEACCESS(PVAL)
78770 ELSE
78780 BEGIN
78790 PVALUE^.OSCOPE := 0;
78800 P := INCPTR(PVALUE,PVAL^.OFFSET)
78810 END
78820 END
78830 END;
78840 VALUEREAD(RF,F);
78850 IF WASSTRING THEN
78860 BEGIN PVAL^.PVALUE := P^.FIRSTPTR; EDISPOSE(P, 1) END;
78870 END;
78880 END;
78890 J := COUNT+SZWORD; WHILE J>SZWORD DO
78900 BEGIN
78910 J := J-SZWORD;
78920 XMODE := GETSTKTOP(SZWORD, J);
78930 IF XMODE IN [0..13,15..31] THEN
78940 BEGIN
78950 J := J - SZADDR;
78960 PVAL := ASPTR(GETSTKTOP(SZADDR, J)); WITH PVAL^ DO
78970 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
78980 END
78990 ELSE IF XMODE = 14 THEN J := J - SZPROC
79000 END;
79010 WITH RF^ DO
79020 BEGIN FDEC; IF FTST THEN GARBAGE(RF) END;
79030 END; (*GET*)
79040 (**)
79050 (**)
79060 (*+01() (*$X4*) ()+01*)
79070 (**)
79080 (**)
79090 (*-02()
79100 BEGIN (*OF A68*)
79110 END; (*OF A68*)
79120 ()-02*)
79130 (*+01()
79140 BEGIN (*OF MAIN PROGRAM*)
79150 END (* OF EVERYTHING *).
79160 ()+01*)

556
lang/a68s/liba68s/global.p Normal file
View file

@ -0,0 +1,556 @@
08000 #include "rundecs.h"
08010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
08020 (**)
08030 (*+01() (*$X6*) ()+01*)
08040 PROCEDURE STANDINC(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
08050 PROCEDURE STANDOUT(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
08060 PROCEDURE STANDBAC(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
08070 (*+01() (*$X4*) ()+01*)
08080 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN;
08090 PROCEDURE ERRORR(N: INTEGER); EXTERN;
08100 (*+05() FUNCTION TIME: REAL; EXTERN; ()+05*)
08110 PROCEDURE CALLPASC ; EXTERN;
08120 PROCEDURE ABORT; EXTERN;
08130 (*+02()
08140 PROCEDURE ACLS(FIL: FETROOMP); EXTERN;
08150 PROCEDURE STOPEN (VAR PF: FYL; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH(COV:OBJECTP;L:LFNTYPE) ); EXTERN;
08160 ()+02*)
08170 (*+01() (*$X6*) ()+01*)
08180 FUNCTION PROC(PROCEDURE P):ASPROC;EXTERN;
08190 (*-01()
08200 FUNCTION PROCH( PROCEDURE P( COV: OBJECTP ; L: LFNTYPE ) ): ASPROC ; EXTERN ;
08210 ()-01*)
08220 (*+01() (*$X4*) ()+01*)
08230 (**)
08240 (*+24()
08250 PROCEDURE FINDSORT(POINT: OBJECTP; VAR GETSORT: ALFA);
08260 BEGIN
08270 (*+01() (*$T-*) ()+01*)
08280 CASE POINT^.SORT OF
08290 STRUCT: GETSORT:='STRUCT ';
08300 MULT: GETSORT:='MULT ';
08310 IELS: GETSORT:='IELS ';
08320 ROUTINE:GETSORT:='ROUTINE ';
08330 REF1: GETSORT:='REF1 ';
08340 REF2: GETSORT:='REF2 ';
08350 REFN: GETSORT:='REFN ';
08360 CREF: GETSORT:='CREF ';
08370 REFR: GETSORT:='REFR ';
08380 REFSL1: GETSORT:='REFSL1 ';
08390 REFSLN: GETSORT:='REFSLN ';
08400 RECR: GETSORT:='RECR ';
08410 RECN: GETSORT:='RECN ';
08420 UNDEF: GETSORT:='UNDEF ';
08430 NILL: GETSORT:='NILL ';
08440 STRING: GETSORT:='STRING ';
08450 END
08460 END;
08470 (**)
08480 (**)
08490 PROCEDURE PRINTSORT(POINT: OBJECTP);
08500 BEGIN
08510 CASE POINT^.SORT OF
08520 STRUCT: WRITE('STRUCT');
08530 MULT: WRITE('MULT');
08540 IELS: WRITE('IELS');
08550 ROUTINE:WRITE('ROUTINE');
08560 REF1: WRITE('REF1');
08570 REF2: WRITE('REF2');
08580 REFN: WRITE('REFN');
08590 CREF: WRITE('CREF');
08600 REFR: WRITE('REFR');
08610 REFSL1: WRITE('REFSL1');
08620 REFSLN: WRITE('REFSLN');
08630 RECR: WRITE('RECR');
08640 RECN: WRITE('RECN');
08650 UNDEF: WRITE('UNDEF');
08660 NILL: WRITE('NILL');
08670 END;
08680 WRITELN(' SORT');
08690 (* ( $T+ ) *)
08700 END;
08710 (**)
08720 (**)
08730 PROCEDURE PRINTDESC(ADESC: OBJECTP);
08740 VAR I:INTEGER;
08750 BEGIN
08760 WITH ADESC^ DO
08770 BEGIN
08780 WRITE('SIZ',SIZE:2,' D0',D0:2,' LBJ',LBADJ:2);
08790 WRITE(' LIUIDI');
08800 FOR I := 0 TO ROWS DO WITH DESCVEC[I] DO
08810 WRITE(LI:2, UI:2, DI:2);
08820 WRITELN
08830 END;
08840 END;
08850 ()+24*)
08860 (**)
08870 (**)
08880 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP;
08890 VAR POINT :OBJECTP;
08900 PTR: UNDRESSP;
08910 BEGIN
08920 IF LENGTH<0 THEN LENGTH := 0;
08930 ENEW(POINT, STRINGCONST+((LENGTH + CHARPERWORD - 1) DIV CHARPERWORD)*SZWORD);
08940 (*-02() POINT^.FIRSTWORD := SORTSHIFT * ORD(STRING); ()-02*)
08950 (*+02() POINT^.PCOUNT:=0; POINT^.SORT:=STRING; ()+02*)
08960 POINT^.STRLENGTH := LENGTH;
08970 PTR := INCPTR(POINT, STRINGCONST+((LENGTH-1) DIV CHARPERWORD)*SZWORD);
08980 IF LENGTH<>0 THEN PTR^.FIRSTWORD := 0;
08990 CRSTRING := POINT
09000 END;
09010 (**)
09020 (**)
09030 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP;
09040 VAR NEWSTRUCT: OBJECTP;
09050 TEMPOS, STRUCTPOS, STRUCTSIZE, COUNT: INTEGER;
09060 PTR, PTR1: UNDRESSP;
09070 BEGIN
09080 STRUCTSIZE:= TEMPLATE^[0];
09090 ENEW(NEWSTRUCT, STRUCTSIZE+STRUCTCONST);
09100 WITH NEWSTRUCT^ DO
09110 BEGIN
09120 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
09130 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
09140 (*+01() SECONDWORD := 0; ()+01*)
09150 OSCOPE := 0 ;
09160 LENGTH := STRUCTSIZE+STRUCTCONST;
09170 DBLOCK:= TEMPLATE;
09180 PTR := INCPTR(NEWSTRUCT, STRUCTCONST);
09190 PTR^.FIRSTWORD := INTUNDEF;
09200 PTR1 := INCPTR(PTR, SZWORD);
09210 MOVELEFT(PTR, PTR1, STRUCTSIZE-SZWORD);
09220 TEMPOS:= 1;
09230 STRUCTPOS := TEMPLATE^[1];
09240 WHILE STRUCTPOS >= 0
09250 DO BEGIN
09260 PTR := INCPTR(NEWSTRUCT, STRUCTCONST+STRUCTPOS);
09270 PTR^.FIRSTPTR := UNDEFIN;
09280 TEMPOS:= TEMPOS+1;
09290 STRUCTPOS := TEMPLATE^[TEMPOS];
09300 END;
09310 END;
09320 CRSTRUCT := NEWSTRUCT
09330 END;
09340 (**)
09350 (**)
09360 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); FORWARD;
09370 (**)
09380 (**)
09390 (*+02()
09400 PROCEDURE ACLOSE(EFET: FETROOMP);
09410 VAR NAME:OBJECTP;
09420 BEGIN
09430 WITH EFET^ DO
09440 IF UFD>2 THEN (*USER'S FILE*)
09450 BEGIN NAME := INCPTR(FNAME, -STRINGCONST);
09460 FPDEC(NAME^); IF FPTST(NAME^) THEN GARBAGE(NAME);
09470 END;
09480 ACLS(EFET);
09490 END;
09500 ()+02*)
09510 PROCEDURE GARBAGE(* (ANOBJECT: OBJECTP) *) ;
09520 LABEL 1;
09530 VAR ASINT: INTEGER;
09540 BACK, HEAD: OBJECTP; TEMPLATE: DPOINT;
09550 TEMP: OBJECTP;
09560 PTR: UNDRESSP;
09570 ELSIZE, SIZEACC, COUNT, STRUCTPOS, TEMPOS: INTEGER;
09580 ISHEAD: BOOLEAN;
09590 GETSORT: ALFA;
09600 PFET: FETROOMP;
09610 BEGIN
09620 (*+24()(*BUGFILE
09630 FINDSORT(ANOBJECT, GETSORT);
09640 WRITELN(BUGFILE, 'GARBGE', GETSORT, 'AT', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) ,
09650 'C=', ANOBJECT^.PCOUNT:4);
09660 BUGFILE*)()+24*)
09670 1: WITH ANOBJECT^ DO
09680 BEGIN
09690 (*+01() IF ORD(ANOBJECT)=0 THEN HALT; (*FOR CATCHING BUGS - SHOULDN'T HAPPEN*) ()+01*)
09700 CASE SORT OF
09710 STRUCT:
09720 BEGIN
09730 TEMPLATE:= DBLOCK;
09740 TEMPOS:= 1;
09750 STRUCTPOS:= TEMPLATE^[1];
09760 WHILE STRUCTPOS>=0 DO
09770 BEGIN
09780 PTR := INCPTR(ANOBJECT, STRUCTCONST+STRUCTPOS);
09790 WITH PTR^.FIRSTPTR^ DO
09800 BEGIN FDEC; IF FTST THEN GARBAGE(PTR^.FIRSTPTR) END;
09810 TEMPOS:= TEMPOS+1;
09820 STRUCTPOS:= TEMPLATE^[TEMPOS]
09830 END;
09840 EDISPOSE(ANOBJECT, LENGTH)
09850 END;
09860 IELS:
09870 BEGIN
09880 TEMPLATE := DBLOCK;
09890 IF ORD(TEMPLATE)<=MAXSIZE (*NOT STRUCT*) THEN
09900 BEGIN
09910 IF ORD(TEMPLATE)=0 (*DRESSED*) THEN
09920 BEGIN
09930 PTR := INCPTR(ANOBJECT, ELSCONST);
09940 WHILE ORD(PTR)<ORD(ANOBJECT)+ELSCONST+D0 DO
09950 BEGIN
09960 WITH PTR^.FIRSTPTR^ DO
09970 BEGIN
09980 FDEC;
09990 IF FTST THEN GARBAGE(PTR^.FIRSTPTR)
10000 END;
10010 PTR := INCPTR(PTR, SZADDR)
10020 END
10030 END
10040 END
10050 ELSE BEGIN (*UNDRESSED STRUCTURES*)
10060 ELSIZE:= TEMPLATE^[0];
10070 IF TEMPLATE^[1] >= 0 THEN
10080 BEGIN
10090 COUNT:= D0;
10100 ASINT:= ELSCONST;
10110 WHILE COUNT>0 DO
10120 BEGIN
10130 TEMPOS := 1;
10140 STRUCTPOS := TEMPLATE^[1];
10150 WHILE STRUCTPOS>=0 DO
10160 BEGIN
10170 PTR := INCPTR(ANOBJECT, ASINT+STRUCTPOS);
10180 WITH PTR^.FIRSTPTR^ DO
10190 BEGIN FDEC;
10200 IF FTST THEN GARBAGE(PTR^.FIRSTPTR)
10210 END;
10220 TEMPOS := TEMPOS+1;
10230 STRUCTPOS := TEMPLATE^[TEMPOS]
10240 END;
10250 ASINT:= ASINT+ELSIZE;
10260 COUNT:= COUNT-ELSIZE
10270 END
10280 END
10290 END;
10300 EDISPOSE(ANOBJECT, ELSCONST+D0)
10310 END;
10320 MULT:
10330 (*ASSERT: THIS MULTIPLE IS NOT SLICED*)
10340 IF PVALUE=NIL (* A BOUNDS BLOCK *) THEN
10350 EDISPOSE(ANOBJECT, MULTCONST+(ROWS+1)*SZPDS)
10360 ELSE
10370 BEGIN
10380 BACK := BPTR;
10390 IF BACK<>NIL THEN
10400 BEGIN (*NOT SLICED BUT A SLICE*)
10410 HEAD:= FPTR;
10420 IF ANOBJECT<>BACK^.IHEAD THEN
10430 BEGIN (*NOT FIRST SLICE*)
10440 BACK^.FPTR:= HEAD;
10450 IF HEAD<>NIL THEN
10460 HEAD^.BPTR:= BACK
10470 END
10480 ELSE
10490 IF HEAD<>NIL (* THE FIRST SLICE AND NOT THE LAST SLICE *) THEN
10500 BEGIN
10510 BACK^.IHEAD:= HEAD;
10520 HEAD^.BPTR := BACK
10530 END
10540 ELSE
10550 BEGIN (*THE ONLY SLICE*)
10560 BACK^.IHEAD := NIL;
10570 FPDEC(BACK^);
10580 IF FPTST(BACK^) THEN GARBAGE(BACK)
10590 END
10600 END;
10610 FPDEC(PVALUE^); TEMP := PVALUE;
10620 EDISPOSE(ANOBJECT, MULTCONST+(ROWS+1)*SZPDS);
10630 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
10640 END;
10650 REFN:
10660 BEGIN
10670 FPDEC(PVALUE^); TEMP := PVALUE;
10680 EDISPOSE(ANOBJECT, REFNSIZE);
10690 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
10700 END;
10710 REFSLN:
10720 BEGIN
10730 FPDEC(ANCESTOR^);
10740 TEMP := ANCESTOR;
10750 EDISPOSE(ANOBJECT, REFSLNCONST+(ROWS+1)*SZPDS);
10760 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
10770 END;
10780 REFSL1:
10790 BEGIN
10800 FPDEC(ANCESTOR^);
10810 TEMP := ANCESTOR;
10820 EDISPOSE(ANOBJECT, REFSL1SIZE);
10830 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
10840 END;
10850 REFR:
10860 BEGIN
10870 FPDEC(PVALUE^); TEMP := PVALUE;
10880 EDISPOSE(ANOBJECT, REFRCONST+(ROWS+1)*SZPDS);
10890 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
10900 END;
10910 RECR:
10920 BEGIN
10930 BACK:= PREV;
10940 HEAD:= NEXT;
10950 BACK^.NEXT:= HEAD;
10960 IF HEAD <> NIL THEN
10970 HEAD^.PREV:= BACK;
10980 FPDEC(PVALUE^); TEMP := PVALUE;
10990 EDISPOSE(ANOBJECT, RECRCONST+(ROWS+1)*SZPDS);
11000 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
11010 END;
11020 RECN:
11030 BEGIN
11040 BACK := PREV;
11050 HEAD := NEXT;
11060 BACK^.NEXT := HEAD;
11070 IF HEAD<>NIL THEN
11080 HEAD^.PREV:= BACK;
11090 FPDEC(PVALUE^); TEMP := PVALUE;
11100 EDISPOSE(ANOBJECT, RECNSIZE);
11110 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
11120 END;
11130 CREF:
11140 EDISPOSE(ANOBJECT, CREFSIZE);
11150 REF1:
11160 EDISPOSE(ANOBJECT, REF1SIZE);
11170 (*-01() REF2:
11180 EDISPOSE(ANOBJECT, REF2SIZE); ()-01*)
11190 ROUTINE:
11200 EDISPOSE(ANOBJECT, ROUTINESIZE);
11210 PASCROUT:
11220 EDISPOSE(ANOBJECT, PROUTINESIZE);
11230 STRING:
11240 EDISPOSE(ANOBJECT, STRINGCONST+((STRLENGTH+CHARPERWORD-1) DIV CHARPERWORD)*SZWORD);
11250 UNDEF, NILL:
11260 PCOUNT := 255; (*MUSTN'T BE COLLECTED, OF COURSE*)
11270 COVER:
11280 BEGIN
11290 IF ASSOC THEN
11300 BEGIN FPDEC(ASSREF^); IF FPTST(ASSREF^) THEN GARBAGE(ASSREF) END
11310 ELSE BEGIN
11320 IF OPENED IN STATUS THEN ACLOSE(BOOK);
11330 PFET := BOOK;
11340 IF NOT(STARTUP IN STATUS) THEN DISPOSE(PFET)
11350 END;
11360 EDISPOSE(ANOBJECT, COVERSIZE)
11370 END
11380 END (*ESAC*)
11390 END (*OF WITH*)
11400 END; (*OF GARBAGE*)
11410 (**)
11420 (**)
11430 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP;
11440 (*PRODUCES EITHER A MULT,RECR,REFR OR A REFSLN FROM A MULT OR A REFSLN
11450 N.B. NO PCOUNTS ARE UPDATED*)
11460 VAR NEWDESC: OBJECTP;
11470 COUNT: INTEGER;
11480 BEGIN
11490 COUNT := MULTCONST (*REFSLNCONST*) + (ORIGINAL^.ROWS + 1)*SZPDS;
11500 ENEW(NEWDESC, COUNT);
11510 WITH NEWDESC^ DO
11520 BEGIN
11530 MOVELEFT(ORIGINAL, NEWDESC, COUNT);
11540 SORT := NEWSORT;
11550 PCOUNT := 0;
11560 END;
11570 COPYDESC := NEWDESC
11580 END;
11590 (**)
11600 (**)
11610 (*+01() (*$X6*) ()+01*)
11620 PROCEDURE OPENCOVER(
11630 PFET: FETROOMP; VAR PCOV: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP; L: LFNTYPE) ()-01*)
11640 );
11650 BEGIN
11660 ENEW(PCOV, COVERSIZE);
11670 WITH PCOV^ DO
11680 BEGIN
11690 (*-02() FIRSTWORD := SORTSHIFT * ORD(COVER) + INCRF; ()-02*)
11700 (*+02() PCOUNT:=1; SORT:=COVER; ()+02*)
11710 BOOK := PFET;
11720 ASSOC := FALSE;
11730 OSCOPE := 1;
11740 CHANNEL := PROC(*-01()H()-01*)(CH);
11750 COFCPOS := 1; LOFCPOS := 1; POFCPOS := 1;
11760 CH(PCOV, LFN);
11770 END
11780 END;
11790 (**)
11800 (**)
11810 PROCEDURE START68;
11820 (*INITIALIZATION OF RUN68*)
11830 VAR PINT: INTPOINT;
11840 CURR: IPOINT;
11850 TEMP: PACKED RECORD CASE SEVERAL OF
11860 1: (INT: INTEGER);
11870 2: (ALF: LFNTYPE);
11880 3: (LFN: PACKED ARRAY [1..7] OF CHAR;
11890 (*+01() EFET1: 0..777777B ()+01*) );
11900 0 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ;
11910 END;
11920 (*+01() AW66: ^W66 ; ()+01*)
11930 TEMP1: REALTEGER;
11940 I: INTEGER;
11950 EFET: INTEGER;
11960 (*+01() PROCEDURE ESTART(CURR: IPOINT); EXTERN; ()+01*)
11970 (*+02() PROCEDURE ESTART_(VAR INF,OUTF : TEXT); EXTERN;
11980 FUNCTION MAXR REAL; EXTERN; ()+02*)
11990 (*-02() PROCEDURE STOPEN(
12000 VAR PF: FYL; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP ; L: LFNTYPE ) ()-01*)
12010 ); EXTERN; ()-02*)
12020 BEGIN
12030 (*+01() CPUCLOCK := -CLOCK; ()+01*)
12040 (*-02() CURR := STATIC(ME)+FIRSTIBOFFSET;
12050 SETMYSTATIC(CURR); ()-02*)
12060 (*+01() ESTART(CURR); (*TO DO ALL THE MACHINE-DEPENDENT INITIALIZATIONS*) ()+01*)
12070 (*+02() ESTART_(INPUT,OUTPUT); (*THIS ALSO SETS UP THE FILES*)
12080 CURR := STATIC(ME);(*ESTART SET UP START68'S STATIC LINK*) ()+02*)
12090 SCOPE := 1;
12100 BITPATTERN.MASK := 0; BITPATTERN.COUNT := 0;
12110 TRACE := NIL;
12120 LEVEL := 0; PROCBL := NIL;
12130 LINENO := 0;
12140 (*+02()INTUNDEF := -32000 -768; ()+02*)
12150 WITH FIRSTRG DO WITH FIRSTW DO
12160 BEGIN
12170 LOOPCOUNT := 0; RGIDBLK := NIL; RECGEN := NIL;
12180 RGSCOPE := 1;
12190 (*-41()
12200 RIBOFFSET := INCPTR( ASPTR( CURR ) , IBCONST ) ;
12210 RGNEXTFREE := INCPTR(RIBOFFSET, RGCONST+SZINT+3*SZADDR (*+02()+3*SZREAL()+02*)) ;
12220 ()-41*)
12230 (*+41()
12240 RIBOFFSET := INCPTR( ASPTR( CURR ) , IBCONST + RGCONST ) ;
12250 RGLASTUSED := INCPTR(RIBOFFSET, -SZINT-3*SZADDR (*+02()-3*SZREAL()+02*)) ;
12260 ()+41*)
12270 END;
12280 ENEW(UNDEFIN, MULTCONST+8*SZPDS);
12290 (*SHOULD BE, INTER ALIA, THE EMPTY STRING AND THE FLATTEST MULT AND AN UNOPENED COVER*)
12300 WITH UNDEFIN^ DO
12310 BEGIN
12320 (*-02() FIRSTWORD := SORTSHIFT * ORD(UNDEF); ()-02*)
12330 (*+02() PCOUNT:=0; SORT:=UNDEF; ()+02*)
12340 (*+01() SECONDWORD := 0; ()+01*)
12350 PCOUNT := 255;
12360 ANCESTOR := UNDEFIN;
12370 OSCOPE := 1;
12380 ENEW(HIGHPCOUNT,MULTCONST+8*SZPDS);
12390 PVALUE := HIGHPCOUNT;
12400 WITH PVALUE^ DO
12410 BEGIN
12420 (*-02() FIRSTWORD := SORTSHIFT * ORD(UNDEF); ()-02*)
12430 (*+02() PCOUNT:=0; SORT:=UNDEF; ()+02*)
12440 (*+01() SECONDWORD := 0; ()+01*)
12450 ANCESTOR := UNDEFIN;
12460 PCOUNT := 255;
12470 PVALUE := UNDEFIN^.PVALUE;
12480 OSCOPE := 1;
12490 OFFSET := HIOFFSET;
12500 ROWS := 7;
12510 STRLENGTH := 0;
12520 STATUS := [];
12530 WITH DESCVEC[0] DO BEGIN LI := MAXBOUND; UI := MINBOUND END;
12540 FOR I := 1 TO 7 DO DESCVEC[I] := DESCVEC[1]
12550 END;
12560 OFFSET := HIOFFSET;
12570 ROWS := 7;
12580 STRLENGTH := 0;
12590 STATUS := [];
12600 WITH DESCVEC[0] DO BEGIN LI := MAXBOUND; UI := MINBOUND END;
12610 FOR I := 1 TO 7 DO DESCVEC[I] := DESCVEC[1]
12620 END;
12630 NILPTR := COPYDESC(UNDEFIN, NILL);
12640 NILPTR^.PCOUNT := 255;
12650 PUTSTRING := CRSTRING(2*REALWIDTH+2*EXPWIDTH+9);
12660 PUTSTRING^.PCOUNT := 255;
12670 ALLCHAR := []; FOR I := 0 TO (*+01()58()+01*) (*-01()MAXABSCHAR()-01*) DO ALLCHAR := ALLCHAR+[CHR(I)];
12680 (*+01() ALLCHAR1 := []; FOR I := 59 TO 63 DO ALLCHAR1 := ALLCHAR1+[CHR(I-59)]; ()+01*)
12690 ENEW(COMPLEX, 2*SZWORD);
12700 COMPLEX^[0] := 2*SZREAL; COMPLEX^[1] := -1; (*DBLOCK FOR .COMPL*)
12710 ENEW(FILEBLOCK, 12*SZWORD+SZTERMSET); (*DBLOCK FOR FILE*)
12720 FILEBLOCK^[0] := 5*SZADDR+SZTERMSET; FILEBLOCK^[1] := 0; FILEBLOCK^[2] := SZADDR; FILEBLOCK^[3] := 2*SZADDR;
12730 FILEBLOCK^[4] := 3*SZADDR; FILEBLOCK^[5] := 4*SZADDR; FILEBLOCK^[6] := -1;
12740 FILEBLOCK^[7] := 12; FILEBLOCK^[8] := 12; FILEBLOCK^[9] := 12; FILEBLOCK^[10] := 12;
12750 FILEBLOCK^[11] := 0; FOR I := 1 TO SZTERMSET DIV SZWORD DO FILEBLOCK^[11+I] := 1;
12760 NEW(PASCADDR); TEMP1.PROCC := PROC(CALLPASC); PASCADDR^.XBASE := TEMP1.PROCVAL.PROCADD;
12770 (*+54()
12780 ENEW(EXCEPTDB, 4*SZWORD);
12790 EXCEPTDB^[0] := 2*SZINT; EXCEPTDB^[1] := -1;
12800 EXCEPTDB^[2] := 1; EXCEPTDB^[3] := 0;
12810 ()+54*)
12820 (*-44()
12830 LASTRANDOM := ROUND(MAXINT/2);
12840 (*-01() (*-05() HALFPI.ACTUALPI := 2*ARCTAN(1.0); ()-05*) ()-01*)
12850 (*+01() HALFPI.FAKEPI := FAKEPI; ()+01*)
12860 (*+02() PI := 2.0*HALFPI.ACTUALPI;
12870 SMALLREAL := 1.0;
12880 WHILE (1.0+SMALLREAL*2.0>1.0) AND (1.0-SMALLREAL*2.0<1.0) DO SMALLREAL := SMALLREAL/2.0;
12890 MAXREAL := MAXR;
12900 ()+02*)
12910 (*+05() HALFPI.FAKEPI := FAKEPI ; HALFPI.FAKEPI1 := FAKEPI1 ; ()+05*)
12920 ()-44*)
12930 UNINT := INTUNDEF;
12940 (*+02() UNINTCOPY := UNINT; UNDEFINCOPY := UNDEFIN; ()+02*)
12950 (*+01()
12960 WITH TEMP DO
12970 BEGIN
12980 PINT := ASPTR(2); (*1ST PROGRAM PARAMETER*)
12990 INT := PINT^;
13000 IF INT = 0 THEN LFN := 'INPUT::' ;
13010 STOPEN(INPUT, STIN, ALF , STANDINC);
13020 EFET := CURR-FIRSTIBOFFSET+INPUTEFET;
13030 LFN := 'INPUT::'; EFET1 := EFET+1;
13040 PINT^ := INT;
13050 PINT := ASPTR(3); (*2ND PROGRAM PARAMETER*)
13060 INT := PINT^;
13070 IF INT = 0 THEN LFN := 'OUTPUT:' ;
13080 STOPEN(OUTPUT, STOUT, ALF , STANDOUT);
13090 EFET := CURR-FIRSTIBOFFSET+OUTPUTEFET;
13100 AW66 := ASPTR(66B);
13110 IF (AW66^.JOPR=3) AND (LFN='OUTPUT:') THEN WRITELN(OUTPUT, 'STARTING ...');
13120 LFN := 'OUTPUT:'; EFET1 := EFET+1;
13130 PINT^ := INT;
13140 PINT := ASPTR(4);
13150 PINT^ := INT; (*IN CASE USER OPENS ANOTHER FILE ON OUTPUT*)
13160 STBACK := UNDEFIN;
13170 END;
13180 ()+01*)
13190 (*+02()
13200 STOPEN(INPUT, STIN, NIL, STANDINC);
13210 STOPEN(OUTPUT, STOUT, NIL, STANDOUT);
13220 WRITELN(OUTPUT, 'STARTING ...');
13230 ()+02*)
13240 (*+05()
13250 STOPEN(INPUT, STIN, NIL , STANDINC);
13260 STOPEN(OUTPUT, STOUT, NIL , STANDOUT);
13270 WRITELN(ERROR, 'STARTING ...');
13280 ()+05*)
13290 END;
13300 (*+01() (*$X4*) ()+01*)
13310 (**)
13320 (**)
13330 (**)
13340 (**)
13350 PROCEDURE STOP68;
13360 (*+01() PROCEDURE PEND(EFET: INTEGER); EXTERN; ()+01*)
13370 (*+02() PROCEDURE ESTOP_; EXTERN; ()+02*)
13380 BEGIN
13390 (*+05() FLSBUF(STOUT^.PVALUE^.PCOVER^.BOOK^.XFILE, CHR(10)); ()+05*)
13400 WRITELN((*-05()OUTPUT()-05*)(*+05()ERROR()+05*));
13410 WRITELN((*-05()OUTPUT()-05*)(*+05()ERROR()+05*), ' ... AND YET ANOTHER ALGOL68 PROGRAM RUNS TO COMPLETION');
13420 (*+01() WRITELN(OUTPUT, ' CPU ', (CPUCLOCK+CLOCK)/1000:6:3); ()+01*)
13430 (*+05() WRITELN(ERROR, ' CPU ', TIME :5:2); ()+05*)
13440 (*+01() PEND(STATIC(ME)-FIRSTIBOFFSET+OUTPUTEFET) ()+01*)
13450 (*+02() ESTOP_; ()+02*)
13460 END;
13470 (**)
13480 (**)
13490 (**)
13500 (**)
13510 (*-02() BEGIN END ; ()-02*)
13520 (*+01()
13530 BEGIN (*OF MAIN PROGRAM*)
13540 END (*OF EVERYTHING*).
13550 ()+01*)

169
lang/a68s/liba68s/globale.e Normal file
View file

@ -0,0 +1,169 @@
#include "e.h"
exa .HTOP ; the label holtop
exa .1 ; the Pascal global area
exa _extfl ; the routine '_ini' puts 'input' & 'output' here
exp $ESTART0
exp $ESTART_
exp $ESTOP_
exp $ABORT
; PROCEDURE ESTART0
pro $ESTART0,0
lor 0 ; my LB
dup SZADDR
dch ; m_a_i_n's LB
dup SZADDR
str 0 ; pretend I am in m_a_i_n
lae .HTOP-FIRSTIBOFFSET; destination address (holtop-firstiboffset)
; now calc how much to move
lal 0
lor 0
sbs SZWORD ; subtract address of param from lb to get link space
loc SZWORD+SZADDR+SZADDR
ads SZWORD ; allow for one parameter of m_a_i_n
bls SZWORD ; block move
; now the global area contains an exact copy of
; m_a_i_n's stack frame, and main will subsequently
; adjust its LB to point to this global copy, thus
; making it a part of the official stack.
str 0 ; get my LB back
ret 0
end 0
; PROCEDURE ESTART_ (INPUT,OUTPUT);
pro $ESTART_,0
.2
con 2,0,0 ; array that is to be _extfl
.3
con 0I SZADDR ; PASCAL trap routine
.4
con 0 ; trapn
con 0 ; signaln
LFL SZADDR+SZADDR ; base address for input (2nd param)
lae .1
sbs SZWORD ; subtract address from hol1 to get offset
ste .2+SZWORD ; store in array of offsets
LFL SZADDR ; and again for output (1st param after static link)
lae .1
sbs SZWORD
ste .2+SZWORD+SZWORD ; store in array
lxl 2 ; params for _ini
lae .2
lae .1
lxa 2
cal $_ini
asp SZADDR+SZADDR+SZADDR+SZADDR
loc A68STAMP ; m_a_i_n's frame stamp, for isa68, any positive number
ste .HTOP-FSTAMPOFFSET ; it is in a SZWORD integer, 1st local var
inp $_usigs
cal $_usigs ; catch UNIX interrupts as EM trap 15
inp $_acatch
lpi $_acatch ; A68 trap routine
sig
lae .3
sti SZWORD ; preserve PASCAL trap routine
zre .4 ; trapn
ret 0
end 0
; procedure usigs;
; var i: integer;
; begin
; for i := 1 to 16 do signal(i, ucatch);
; end;
pro $_usigs,SZWORD
mes 9,0
loc 1
loc 16
bgt *2
loc 1
stl -SZWORD
1
zer SZWORD
inp $_ucatch
lpi $_ucatch
lol -SZWORD
cal $signal
asp SZWORD+SZWORD+SZWORD
lol -SZWORD
loc 16
beq *2
lol -SZWORD
inc
stl -SZWORD
bra *1
2
mes 3,-SZWORD,4,1
ret 0
end SZWORD
; procedure ucatch(signo: integer);
; begin
; trap(15);
; end;
pro $_ucatch,0
mes 9,4
lol 0
ste .4+SZWORD ; signaln
#ifdef BSD4
loc 0
cal $sigsetmask ; unblock all signals
asp SZWORD
LLC 0 ; SIG_DFL
lol 0
cal $signal ; because 4.2 Inices do not reset caught signals
asp SZADDR+SZWORD
#endif
loc 15
cal $trap
asp SZWORD
mes 3,0,4,0
ret 0
end 0
pro $_acatch,SZWORD
loc PASCALSTAMP
stl -SZWORD
lol 0 ; EM trap number
dup SZWORD
ste .4 ; trapn
ngi SZWORD
lxl 0
cal $ERRORR ; should never return
end SZWORD
pro $ESTOP_,0
loc 0
cal $_hlt
end 0
pro $ABORT,0
loe .4 ; trapn
zne *1
loc 1 ; if abort is called then presumably some error has
; occured, thus exit code 1
cal $_hlt
1
loe .4 ; trapn
loc 15
bne *2 ; if not a UNIX signal
cal $_cleanup
loe .4+SZWORD ; signaln
cal $getpid
lfr SZWORD
cal $kill
2
lae .3 ; PASCAL trap routine
loi SZWORD
dup SZWORD
zeq *3 ; no PASCAL trap routine
sig
asp SZWORD
loe .4
trp ; now let PASCAL handle the same trap
3
loe .4 ; trapn
cal $_catch
end 0

80
lang/a68s/liba68s/gtot.p Normal file
View file

@ -0,0 +1,80 @@
33700 #include "rundecs.h"
33710 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
33720 (**)
33730 (**)
33740 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); EXTERN;
33750 FUNCTION DRESSN (CONTENTS: UNDRESSP; TEMPLATE: DPOINT): OBJECTP; EXTERN ;
33760 (**)
33770 (**)
33780 (*-01() (*-05()
33790 FUNCTION GTOTS(NAK: NAKED): A68INT;
33800 (*PGETTOTAL*)
33810 BEGIN
33820 GTOTS := NAK.POINTER^.FIRSTINT;
33830 IF FPTST(NAK.STOWEDVAL^) THEN GARBAGE(NAK.STOWEDVAL)
33840 END;
33850 (**)
33860 (**)
33870 FUNCTION GTOTS2(NAK: NAKED): A68LONG;
33880 (*PGETTOTAL+1*)
33890 BEGIN
33900 GTOTS2 := NAK.POINTER^.FIRSTLONG;
33910 IF FPTST(NAK.STOWEDVAL^) THEN GARBAGE(NAK.STOWEDVAL)
33920 END;
33930 ()-05*) ()-01*)
33940 (**)
33950 (**)
33960 FUNCTION GTOTP(NAK: NAKED): OBJECTP;
33970 (*PGETTOTAL+2*)
33980 VAR RESULT: OBJECTP;
33990 BEGIN WITH NAK DO
34000 BEGIN
34010 RESULT := POINTER^.FIRSTPTR;
34020 IF FPTST(STOWEDVAL^) THEN
34030 BEGIN
34040 FPINC(RESULT^);
34050 GARBAGE(STOWEDVAL);
34060 FPDEC(RESULT^);
34070 END;
34080 GTOTP := RESULT;
34090 END
34100 END;
34110 (**)
34120 (**)
34130 (*-01() (*-05()
34140 FUNCTION GTOTSTR(TEMP: NAKEGER): ASNAKED;
34150 (*PGETTOTCMN+1*)
34160 BEGIN WITH TEMP DO WITH NAK DO
34170 BEGIN
34180 POINTER := INCPTR(STOWEDVAL, POSITION);
34190 GTOTSTR := ASNAK;
34200 END
34210 END;
34220 (**)
34230 (**)
34240 FUNCTION GTOTRFR(TEMP: NAKEGER): ASNAKED;
34250 (*PGETTOTCMN+2*)
34260 BEGIN WITH TEMP DO WITH NAK DO
34270 BEGIN
34280 POINTER := INCPTR(STOWEDVAL^.ANCESTOR^.PVALUE, POSITION);
34290 GTOTRFR := ASNAK;
34300 END
34310 END;
34320 (**)
34330 (**)
34340 FUNCTION GTOTMUL(TEMP: NAKEGER): ASNAKED;
34350 (*PGETTOTCMN+3*)
34360 BEGIN WITH TEMP DO WITH NAK DO
34370 BEGIN
34380 POINTER := INCPTR(STOWEDVAL^.PVALUE, POSITION);
34390 GTOTMUL := ASNAK;
34400 END
34410 END;
34420 ()-05*) ()-01*)
34430 (**)
34440 (**)
34450 (*-02() BEGIN END ; ()-02*)
34460 (*+01()
34470 BEGIN (*OF MAIN PROGRAM*)
34480 END (*OF EVERYTHING*).
34490 ()+01*)

42
lang/a68s/liba68s/gtotref.p Normal file
View file

@ -0,0 +1,42 @@
34600 #include "rundecs.h"
34610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
34620 (**)
34630 (**)
34640 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
34650 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
34660 (**)
34670 (**)
34680 FUNCTION GTOTREF (NAK: NAKED; TEMPLATE: DPOINT): OBJECTP;
34690 (*PGETTOTAL+4*)
34700 VAR OFFSPRING: OBJECTP;
34710 BEGIN
34720 WITH NAK, STOWEDVAL^ DO
34730 BEGIN
34740 CASE SORT OF
34750 UNDEF:ERRORR(RSEL);
34760 NILL:ERRORR(RSELNIL);
34770 REFSL1, REFSLN, REFR, RECR, RECN, REFN:
34780 END;
34790 ENEW(OFFSPRING, REFSL1SIZE);
34800 WITH ANCESTOR^ DO FINC;
34810 WITH OFFSPRING^ DO
34820 BEGIN
34830 (*-02() FIRSTWORD := SORTSHIFT*ORD(REFSL1); ()-02*)
34840 (*+02() PCOUNT:=0; SORT:=REFSL1; ()+02*)
34850 (*+01() SECONDWORD := 0; ()+01*)
34860 ANCESTOR := STOWEDVAL^.ANCESTOR;
34870 OFFSET := POSITION;
34880 DBLOCK := TEMPLATE;
34890 OSCOPE := STOWEDVAL^.OSCOPE
34900 END;
34910 IF FTST THEN GARBAGE(STOWEDVAL)
34920 END; (*WITH*)
34930 GTOTREF := OFFSPRING
34940 END;
34950 (**)
34960 (**)
34970 (*-02() BEGIN END ; ()-02*)
34980 (*+01()
34990 BEGIN (*OF MAIN PROGRAM*)
35000 END (*OF EVERYTHING*).
35010 ()+01*)

24
lang/a68s/liba68s/gvasstx.p Normal file
View file

@ -0,0 +1,24 @@
35100 #include "rundecs.h"
35110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
35120 (**)
35130 (**)
35140 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
35150 (**)
35160 (**)
35170 PROCEDURE GVASSTX(SOURCE: OBJECTP; DEST: UNDRESSP);
35180 (*PASGVART+6,7,8: ASSIGNS PILE VALUE TO GLOBAL VARIABLE*)
35190 BEGIN
35200 FPINC(SOURCE^);
35210 WITH DEST^ DO
35220 BEGIN
35230 FPDEC(FIRSTPTR^); IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
35240 FIRSTPTR := SOURCE;
35250 END;
35260 END;
35270 (**)
35280 (**)
35290 (*-02() BEGIN END ; ()-02*)
35300 (*+01()
35310 BEGIN (*OF MAIN PROGRAM*)
35320 END (*OF EVERYTHING*).
35330 ()+01*)

53
lang/a68s/liba68s/gvscope.p Normal file
View file

@ -0,0 +1,53 @@
35400 #include "rundecs.h"
35410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
35420 (**)
35430 (**)
35440 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
35450 PROCEDURE ERRORR(N :INTEGER); EXTERN;
35460 (**)
35470 (**)
35480 FUNCTION GLDVAR (LOCRG: DEPTHRANGE; PTR: UNDRESSP; IBPT: IPOINT): OBJECTP;
35490 (*PLOADVAR+0,1,2*)
35500 VAR NEWCREFX: OBJECTP;
35510 CURR: IPOINT;
35520 BEGIN
35530 ENEW(NEWCREFX, CREFSIZE);
35540 WITH NEWCREFX^ DO
35550 BEGIN
35560 (*-02() FIRSTWORD := SORTSHIFT * ORD(CREF); ()-02*)
35570 (*+02() PCOUNT:=0; SORT:=CREF; ()+02*)
35580 (*+01() SECONDWORD := 0; ()+01*)
35590 ANCESTOR := NEWCREFX;
35600 PVALUE := HIGHPCOUNT;
35610 IPTR := PTR;
35620 CURR := STATIC(ME);
35630 SETMYSTATIC(IBPT);
35640 OSCOPE := SCOPE+LOCRG;
35650 SETMYSTATIC(CURR)
35660 END;
35670 GLDVAR := NEWCREFX;
35680 END;
35690 (**)
35700 (**)
35710 PROCEDURE GVSCOPE(SOURCE: OBJECTP; LOCRG: DEPTHRANGE; DEST: UNDRESSP; GLOBIB: IPOINT);
35720 (*PSCOPEVAR+1*)
35730 VAR CURR: IPOINT;
35740 BEGIN
35750 CURR := STATIC(ME);
35760 SETMYSTATIC(GLOBIB);
35770 IF SCOPE+LOCRG<SOURCE^.OSCOPE THEN ERRORR(RSCOPE);
35780 SETMYSTATIC(CURR);
35790 FPINC(SOURCE^);
35800 WITH DEST^ DO
35810 BEGIN
35820 FPINC(FIRSTPTR^); IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
35830 FIRSTPTR := SOURCE;
35840 END;
35850 END;
35860 (**)
35870 (**)
35880 (*-02() BEGIN END ; ()-02*)
35890 (*+01()
35900 BEGIN (*OF MAIN PROGRAM*)
35910 END (*OF EVERYTHING*).
35920 ()+01*)

37
lang/a68s/liba68s/heapmul.p Normal file
View file

@ -0,0 +1,37 @@
36000 #include "rundecs.h"
36010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
36020 (**)
36030 (**)
36040 FUNCTION CRMULT(NEWMULT: OBJECTP; TEMPLATE: DPOINT): OBJECTP; EXTERN;
36050 (**)
36060 (**)
36070 FUNCTION HEAPMUL(NEWMULT: OBJECTP; TEMPLATE: DPOINT): OBJECTP;
36080 (*PLEAPGEN+4*)
36090 VAR NEWREF: OBJECTP;
36100 BEGIN
36110 NEWREF := CRMULT(NEWMULT, TEMPLATE);
36120 WITH NEWREF^ DO
36130 BEGIN
36140 SORT := REFR;
36150 OSCOPE := 3;
36160 ANCESTOR := NEWREF; CCOUNT := 1;
36170 END;
36180 HEAPMUL := NEWREF;
36190 END;
36200 (**)
36210 (**)
36220 FUNCTION GENMUL(NEWMULT: OBJECTP; TEMPLATE: DPOINT; LOCRG: DEPTHRANGE): OBJECTP;
36230 (*PLEAPGEN+3*)
36240 VAR NEWREFR: OBJECTP;
36250 BEGIN
36260 NEWREFR := HEAPMUL(NEWMULT, TEMPLATE);
36270 NEWREFR^.OSCOPE := SCOPE+LOCRG;
36280 GENMUL := NEWREFR;
36290 END;
36300 (**)
36310 (**)
36320 (*-02() BEGIN END ; ()-02*)
36330 (*+01()
36340 BEGIN (*OF MAIN PROGRAM*)
36350 END (*OF EVERYTHING*).
36360 ()+01*)

76
lang/a68s/liba68s/heapstr.p Normal file
View file

@ -0,0 +1,76 @@
36400 #include "rundecs.h"
36410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
36420 (**)
36430 (**)
36440 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP; EXTERN;
36450 (**)
36460 (**)
36470 FUNCTION HEAPSTR(TEMPLATE: DPOINT): OBJECTP;
36480 (*PLEAPGEN+1*)
36490 VAR NEWREF: OBJECTP;
36500 BEGIN
36510 IF ORD(TEMPLATE)=SZINT THEN
36520 BEGIN
36530 ENEW(NEWREF, REF1SIZE);
36540 WITH NEWREF^ DO BEGIN
36550 (*-02() FIRSTWORD := SORTSHIFT * ORD(REF1); ()-02*)
36560 (*+02() PCOUNT:=0; SORT:=REF1; ()+02*)
36570 (*+01() SECONDWORD := 0; ()+01*)
36580 ANCESTOR := NEWREF;
36590 PVALUE := HIGHPCOUNT;
36600 OFFSET := REF1SIZE-SZINT;
36610 VALUE := INTUNDEF
36620 END
36630 END
36640 (*-01()
36650 ELSE IF ORD(TEMPLATE)=SZLONG THEN
36660 BEGIN
36670 ENEW(NEWREF, REF2SIZE);
36680 WITH NEWREF^ DO BEGIN
36690 (*-02() FIRSTWORD := SORTSHIFT * ORD(REF2); ()-02*)
36700 (*+02() PCOUNT:=0; SORT:=REF2; ()+02*)
36710 ANCESTOR := NEWREF;
36720 PVALUE := HIGHPCOUNT;
36730 OFFSET := REF2SIZE-SZINT;
36740 LONGVALUE := LONGUNDEF
36750 END
36760 END
36770 ()-01*)
36780 ELSE
36790 BEGIN
36800 ENEW(NEWREF, REFNSIZE);
36810 WITH NEWREF^ DO
36820 BEGIN
36830 (*-02() FIRSTWORD := SORTSHIFT * ORD(REFN); ()-02*)
36840 (*+02() PCOUNT:=0; SORT:=REFN; ()+02*)
36850 (*+01() SECONDWORD := 0; ()+01*)
36860 IF ORD(TEMPLATE)=0 THEN PVALUE := UNDEFIN
36870 ELSE
36880 BEGIN
36890 PVALUE := CRSTRUCT(TEMPLATE);
36900 FPINC(PVALUE^);
36910 ANCESTOR := NEWREF;
36920 OFFSET := STRUCTCONST;
36930 END;
36940 END
36950 END;
36960 NEWREF^.OSCOPE := 3;
36970 HEAPSTR := NEWREF;
36980 END;
36990 (**)
37000 (**)
37010 FUNCTION GENSTR(TEMPLATE: DPOINT; LOCRG: DEPTHRANGE): OBJECTP;
37020 (*PLEAPGEN*)
37030 VAR NEWREF: OBJECTP;
37040 BEGIN
37050 NEWREF := HEAPSTR(TEMPLATE);
37060 NEWREF^.OSCOPE := SCOPE+LOCRG;
37070 GENSTR := NEWREF;
37080 END;
37090 (**)
37100 (**)
37110 (*-02() BEGIN END ; ()-02*)
37120 (*+01()
37130 BEGIN (*OF MAIN PROGRAM*)
37140 END (*OF EVERYTHING*).
37150 ()+01*)

35
lang/a68s/liba68s/hoist.e Normal file
View file

@ -0,0 +1,35 @@
#include "e.h"
exp $HOIST
pro $HOIST,SZADDR ; used to balance the amount of space on the stack
; for a call to PUT or PRINT. This is done by
; loading an amount of dummy data (-1).
; The parameter is the amount of dummy space needed.
lxa 0 ; base address of params
lol SZADDR ; param, after static link, the difference
loc SZADDR+SZWORD ; diff calculated from after param and static link
adu SZWORD ; add last two
ads SZWORD ; add total to arg base
dup SZADDR ; this is the address of 'count'
SFL -SZADDR ; save for later use
loi SZWORD ; load count
lol SZADDR ; load difference
adu SZWORD ; new count
stl SZADDR+SZWORD ; store in new place, at bottom of dummy data
1
loc -1 ; dummy data to PRINT
LFL -SZADDR ; address to place data, initialy where count was
dup SZADDR
adp -SZWORD ; reduce pointer by SZWORD ready for next time
SFL -SZADDR ; re-save
sti SZWORD ; place -1 in target address
lol SZADDR ; use difference as a loop counter now
loc SZWORD
sbi SZWORD ; reduce loop counter by SZWORD
dup SZWORD ; need one to store and one to test
stl SZADDR ; re-save
zgt *1 ; do next SZWORD block
ret 0
end SZADDR

30
lang/a68s/liba68s/is.p Normal file
View file

@ -0,0 +1,30 @@
37200 #include "rundecs.h"
37210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
37220 (**)
37230 (**)
37240 FUNCTION RELSUP(REF: OBJECTP): UNDRESSP; EXTERN;
37250 (**)
37260 (**)
37270 FUNCTION IS(LEFT, RIGHT: OBJECTP): INTEGER;
37280 (*PIDTYREL*)
37290 BEGIN
37300 IF RELSUP(LEFT)=RELSUP(RIGHT) THEN
37310 IS := -1
37320 ELSE IS := 0
37330 END;
37340 (**)
37350 (**)
37360 FUNCTION ISNT(LEFT, RIGHT: OBJECTP): INTEGER;
37370 (*PIDTYREL+1*)
37380 BEGIN
37390 IF RELSUP(LEFT)<>RELSUP(RIGHT) THEN
37400 ISNT := -1
37410 ELSE ISNT := 0
37420 END;
37430 (**)
37440 (**)
37450 (*-02() BEGIN END ; ()-02*)
37460 (*+01()
37470 BEGIN (*OF MAIN PROGRAM*)
37480 END (*OF EVERYTHING*).
37490 ()+01*)

28
lang/a68s/liba68s/linit2.p Normal file
View file

@ -0,0 +1,28 @@
37600 #include "rundecs.h"
37610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
37620 (**)
37630 (**)
37640 (*-01()
37650 FUNCTION LINIT2(TOO: INTEGER; PTR: NOBYLPP): BOOLEAN ;
37660 (*PLOOPINIT+1*)
37670 BEGIN
37680 FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT+1;
37690 WITH PTR^ DO
37700 BEGIN
37710 LOOPTYP := 2;
37720 FROMPART := GETSTKTOP(SZINT, 0);
37730 TOPART := TOO;
37740 LINIT2 := TOPART>=FROMPART;
37750 END;
37760 END;
37770 ()-01*)
37780 (**)
37790 (**)
37800 (*-02()
37810 BEGIN
37820 END ;
37830 ()-02*)
37840 (*+01()
37850 BEGIN (*OF MAIN PROGRAM*)
37860 END (*OF EVERYTHING*).
37870 ()+01*)

34
lang/a68s/liba68s/linit34.p Normal file
View file

@ -0,0 +1,34 @@
37900 #include "rundecs.h"
37910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
37920 (**)
37930 (**)
37940 PROCEDURE LINIT3(BY: INTEGER; PTR: BYLPP) ;
37950 BEGIN
37960 FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT+1;
37970 WITH PTR^ DO
37980 BEGIN
37990 LOOPTYP := 3;
38000 BYPART := BY;
38010 FROMPART := GETSTKTOP(SZINT, 0);
38020 END;
38030 END;
38040 (**)
38050 PROCEDURE LINIT4(FROM: INTEGER; PTR: NOBYLPP) ;
38060 BEGIN
38070 FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT+1;
38080 WITH PTR^ DO
38090 BEGIN
38100 LOOPTYP := 4;
38110 FROMPART := FROM;
38120 END;
38130 END;
38140 (**)
38150 (**)
38160 (*-02()
38170 BEGIN
38180 END ;
38190 ()-02*)
38200 (*+01()
38210 BEGIN (*OF MAIN PROGRAM*)
38220 END (*OF EVERYTHING*).
38230 ()+01*)

43
lang/a68s/liba68s/linitinc.p Normal file
View file

@ -0,0 +1,43 @@
38300 #include "rundecs.h"
38310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
38320 (**)
38330 (**)
38340 FUNCTION LINIT1(TOO: INTEGER; PTR: BYLPP): BOOLEAN ;
38350 (*PLOOPINIT*)
38360 BEGIN
38370 FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT +1 ;
38380 WITH PTR^ DO
38390 BEGIN
38400 LOOPTYP := 1;
38410 BYPART := GETSTKTOP(SZINT, 0);
38420 FROMPART := GETSTKTOP(SZINT, SZINT);
38430 TOPART := TOO;
38440 IF BYPART>0 THEN LINIT1 := TOPART>=FROMPART
38450 ELSE IF BYPART<0 THEN LINIT1 := TOPART<=FROMPART
38460 ELSE LINIT1 := TRUE;
38470 END;
38480 END;
38490 (**)
38500 (**)
38510 (*-01()
38520 FUNCTION LOOPINC(PTR: BYLPP): BOOLEAN ;
38530 BEGIN
38540 WITH PTR^ DO
38550 BEGIN
38560 FROMPART := FROMPART+BYPART;
38570 IF BYPART>0 THEN LOOPINC := TOPART>=FROMPART
38580 ELSE IF BYPART<0 THEN LOOPINC := TOPART<=FROMPART
38590 ELSE LOOPINC := TRUE;
38600 END;
38610 END ;
38620 ()-01*)
38630 (**)
38640 (**)
38650 (*-02()
38660 BEGIN
38670 END ;
38680 ()-02*)
38690 (*+01()
38700 BEGIN (*OF MAIN PROGRAM*)
38710 END (*OF EVERYTHING*).
38720 ()+01*)

5
lang/a68s/liba68s/ln.c Normal file
View file

@ -0,0 +1,5 @@
extern double _ln();
double LN(statlink, x)
int *statlink; double x;
{return(_ln(x));}

30
lang/a68s/liba68s/make Executable file
View file

@ -0,0 +1,30 @@
EMROOT=../../..
case `$EMROOT/bin/ack_sys` in
pdp_v7) ACM=pdp ; BM=0 ;;
vax_bsd4_1a) ACM=vax4 ;;
vax_bsd4_2) ACM=vax4 ;;
vax_sysV_2) ACM=vax4 ;;
pc_ix) ACM=i86 ; BM=0;;
sun3) ACM=sun3 ;;
sun2) ACM=sun2 ;;
m68_unisoft) ACM=m68k2 ;;
m68_sysV_0) ACM=mantra ;;
*) ;;
esac
MACH=${MACH-$ACM}
case $MACH in \
pdp) w=2; p=2; NOFLOAT=0; RECIPE='12 13 119'; ASAR=ar ;; \
m68k2) w=2; p=4; NOFLOAT=1; RECIPE='12 113 19 43 44'; ASAR=aal ;; \
moon3) w=2; p=4; NOFLOAT=1; RECIPE='12 113 19 43 44'; BSD4=-DBSD4; ASAR=aal ;; \
m68020|m68000) w=4; p=4; NOFLOAT=1; RECIPE='112 13 119 43 44'; ASAR=aal ;; \
sun3) w=4; p=4; NOFLOAT=1; RECIPE='112 13 119 43 44'; BSD4=-DBSD4; ASAR=aal ;; \
vax4) w=4; p=4; NOFLOAT=0; RECIPE='112 13 119'; BSD4=-DBSD4; \
ASAR=ar; VAX4=-DVAX4; SOFILES='lpb.o'; RANLIB=ranlib; export RANLIB ;; \
*) echo machine $MACH not known to a68s; exit 1 ;; \
esac
/bin/make -f Makefile MACH=$MACH w=$w p=$p NOFLOAT=$NOFLOAT \
RECIPE="$RECIPE" BSD4=$BSD4 ASAR=$ASAR \
VAX4=$VAX4 SOFILES=$SOFILES $*
# sun3) w=4; p=4; NOFLOAT=0; RECIPE='112 13 119'; BSD4=-DBSD4 ;; \

14
lang/a68s/liba68s/maxr.c Normal file
View file

@ -0,0 +1,14 @@
#include <math.h>
double MAXR(staticlink)
int *staticlink;
#ifdef MAXFLOAT
{ return(MAXFLOAT); }
#else
#ifdef HUGE
{ return(HUGE); }
#else
{ return(0.0); /* obviously wrong*/ }
#endif
#endif

8
lang/a68s/liba68s/mod.c Normal file
View file

@ -0,0 +1,8 @@
MOD(statlink, b , a)
int *statlink ;
int a , b ;
{
int r ;
r = a % b ;
return( r < 0 ? r + ( b < 0 ? - b : b ) : r ) ;
}

101
lang/a68s/liba68s/mulis.p Normal file
View file

@ -0,0 +1,101 @@
61500 #include "rundecs.h"
61510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
61520 (**)
61530 (**)
61540 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
61550 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN;
61560 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
61570 (**)
61580 (**)
61590 FUNCTION MULCI(CH: CHAR; N: INTEGER): OBJECTP;
61600 (*PMULCI*)
61610 VAR POINT: OBJECTP;
61620 I: INTEGER;
61630 BEGIN
61640 POINT := CRSTRING(N);
61650 WITH POINT^ DO
61660 FOR I := 1 TO N DO
61670 CHARVEC[I] := CH;
61680 MULCI := POINT;
61690 END;
61700 (**)
61710 (**)
61720 FUNCTION MULSI(S: OBJECTP; N: INTEGER): OBJECTP;
61730 (*PMULCI-1*)
61740 VAR POINT: OBJECTP;
61750 I, J: INTEGER;
61760 C: CHAR;
61770 BEGIN
61780 WITH S^ DO
61790 BEGIN
61800 POINT := CRSTRING(STRLENGTH*N);
61810 FOR I := 0 TO N-1 DO
61820 FOR J := 1 TO STRLENGTH DO
61830 BEGIN C := CHARVEC[J]; POINT^.CHARVEC[I*STRLENGTH+J] := C END
61840 END;
61850 IF FPTST(S^) THEN GARBAGE(S);
61860 MULSI := POINT;
61870 END;
61880 (**)
61890 (**)
61900 FUNCTION MULIC(N: INTEGER; CH: CHAR): OBJECTP;
61910 (*PMULIC*)
61920 VAR POINT :OBJECTP;
61930 I :INTEGER;
61940 BEGIN
61950 POINT := CRSTRING(N);
61960 WITH POINT^ DO
61970 FOR I := 1 TO N DO
61980 CHARVEC[I] := CH;
61990 MULIC := POINT;
62000 END;
62010 (**)
62020 (**)
62030 FUNCTION MULIS(N: INTEGER; S: OBJECTP): OBJECTP;
62040 (*PMULIC-1*)
62050 VAR POINT: OBJECTP;
62060 I, J: INTEGER;
62070 C: CHAR;
62080 BEGIN
62090 WITH S^ DO
62100 BEGIN
62110 POINT := CRSTRING(STRLENGTH*N);
62120 FOR I := 0 TO N-1 DO
62130 FOR J := 1 TO STRLENGTH DO
62140 BEGIN C := CHARVEC[J]; POINT^.CHARVEC[I*STRLENGTH+J] := C END
62150 END;
62160 IF FPTST(S^) THEN GARBAGE(S);
62170 MULIS := POINT;
62180 END;
62190 (**)
62200 (**)
62210 FUNCTION MULABSI(LEFT: OBJECTP; N: INTEGER): OBJECTP;
62220 (*PTIMESABS*)
62230 VAR PIL: OBJECTP;
62240 BEGIN
62250 WITH LEFT^ DO
62260 CASE SORT OF
62270 REFN:
62280 BEGIN
62290 WITH PVALUE^ DO FDEC;
62300 PVALUE := MULSI(PVALUE, N);
62310 WITH PVALUE^ DO FINC
62320 END;
62330 CREF:
62340 BEGIN PIL := IPTR^.FIRSTPTR;
62350 WITH PIL^ DO FDEC;
62360 PIL := MULSI(PIL, N); IPTR^.FIRSTPTR := PIL;
62370 WITH PIL^ DO FINC
62380 END;
62390 UNDEF: ERRORR(RASSIG);
62400 NILL: ERRORR(RASSIGNIL);
62410 END;
62420 MULABSI := LEFT;
62430 END;
62440 (**)
62450 (**)
62460 (*-02() BEGIN END ; ()-02*)
62470 (*+01()
62480 BEGIN (*OF MAIN PROGRAM*)
62490 END (*OF EVERYTHING*).
62500 ()+01*)

72
lang/a68s/liba68s/nassp.p Normal file
View file

@ -0,0 +1,72 @@
40000 #include "rundecs.h"
40010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
40020 (**)
40030 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
40040 PROCEDURE ERRORR(N :INTEGER); EXTERN;
40050 FUNCTION STRUCTSCOPE(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT):DEPTHRANGE; EXTERN;
40060 PROCEDURE UNDRESSN (COLLECTOR, STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; SOURCEP: OBJECTP); EXTERN ;
40070 PROCEDURE NASSTCMN(ANOBJECT: OBJECTP); EXTERN;
40080 (**)
40090 (**)
40100 FUNCTION NASSTP(TEMP: NAKEGER; SOURCE: OBJECTP; TEMPLATE: DPOINT): ASNAKED;
40110 (*+01() EXTERN ; ()+01*)
40120 (*PASSIGNNT+3*)
40130 (*-01()
40140 BEGIN
40150 WITH TEMP.NAK, STOWEDVAL^.ANCESTOR^ DO
40160 BEGIN
40170 IF FPTWO(PVALUE^) THEN
40180 NASSTCMN(STOWEDVAL);
40190 PVALUE^.OSCOPE := 0;
40200 UNDRESSN(INCPTR(PVALUE, POSITION), INCPTR(SOURCE, STRUCTCONST), TEMPLATE, SOURCE);
40210 END;
40220 NASSTP := TEMP.ASNAK;
40230 END;
40240 (**)
40250 (**)
40260 ()-01*)
40270 FUNCTION NASSNP(TEMP: NAKEGER; TEMP2: NAKEGER; TEMPLATE: DPOINT): ASNAKED;
40280 (*PASSIGNNN*)
40290 VAR DEST: UNDRESSP;
40300 BEGIN
40310 WITH TEMP.NAK, STOWEDVAL^.ANCESTOR^ DO
40320 BEGIN
40330 IF FPTWO(PVALUE^) THEN
40340 NASSTCMN(STOWEDVAL);
40350 PVALUE^.OSCOPE := 0;
40360 DEST := INCPTR(PVALUE, POSITION)
40370 END;
40380 WITH TEMP2.NAK DO
40390 UNDRESSN(DEST, POINTER, TEMPLATE, STOWEDVAL);
40400 NASSNP := TEMP.ASNAK;
40410 END;
40420 (**)
40430 (**)
40440 FUNCTION SCPNTP(TEMP: NAKEGER; SOURCE: OBJECTP; TEMPLATE: DPOINT): ASNAKED;
40450 (*PSCOPENT+3*)
40460 BEGIN
40470 WITH SOURCE^ DO
40480 BEGIN
40490 IF OSCOPE=0 THEN OSCOPE := STRUCTSCOPE(INCPTR(SOURCE, STRUCTCONST), DBLOCK);
40500 IF TEMP.NAK.STOWEDVAL^.OSCOPE<OSCOPE THEN ERRORR(RSCOPE);
40510 END;
40520 SCPNTP := NASSTP(TEMP, SOURCE, TEMPLATE);
40530 END;
40540 (**)
40550 (**)
40560 FUNCTION SCPNNP(TEMP: NAKEGER; TEMP2: NAKEGER; TEMPLATE: DPOINT): ASNAKED;
40570 (*PSCOPENN+0,1*)
40580 BEGIN
40590 IF TEMP.NAK.STOWEDVAL^.OSCOPE<STRUCTSCOPE(TEMP2.NAK.POINTER, TEMPLATE) THEN ERRORR(RSCOPE);
40600 SCPNNP := NASSNP(TEMP, TEMP2, TEMPLATE);
40610 END;
40620 (**)
40630 (**)
40640 (*-02()
40650 BEGIN
40660 END;
40670 ()-02*)
40680 (*+01()
40690 BEGIN (*OF MAIN PROGRAM*)
40700 END (*OF EVERYTHING*).
40710 ()+01*)

100
lang/a68s/liba68s/nassts.p Normal file
View file

@ -0,0 +1,100 @@
38900 #include "rundecs.h"
38910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
38920 (**)
38930 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
38940 PROCEDURE ERRORR(N :INTEGER); EXTERN;
38950 PROCEDURE TESTCC(TARGET: OBJECTP); EXTERN ;
38960 PROCEDURE TESTSS (REFSTRUCT: OBJECTP); EXTERN ;
38970 (**)
38980 (**)
38990 PROCEDURE NASSTCMN(ANOBJECT: OBJECTP);
39000 BEGIN
39010 WITH ANOBJECT^ DO
39020 CASE ANCESTOR^.SORT OF
39030 REFR, RECR:
39040 TESTCC(ANOBJECT);
39050 RECN, REFN:
39060 TESTSS(ANCESTOR);
39070 UNDEF:
39080 ERRORR(RSEL);
39090 NILL:
39100 ERRORR(RSELNIL)
39110 END
39120 END;
39130 (**)
39140 (**)
39150 (*-01() (*-05()
39160 FUNCTION NASSTS(TEMP: NAKEGER; SOURCE: A68INT): ASNAKED;
39170 (*PASSIGNNT*)
39180 VAR DEST: UNDRESSP;
39190 BEGIN
39200 WITH TEMP.NAK, STOWEDVAL^.ANCESTOR^ DO
39210 BEGIN
39220 IF FPTWO(PVALUE^) THEN
39230 NASSTCMN(STOWEDVAL);
39240 PVALUE^.OSCOPE := 0;
39250 DEST := INCPTR(PVALUE, POSITION)
39260 END;
39270 DEST^.FIRSTINT := SOURCE;
39280 NASSTS := TEMP.ASNAK;
39290 END;
39300 (**)
39310 (**)
39320 FUNCTION NASSTS2(TEMP: NAKEGER; SOURCE: A68LONG): ASNAKED;
39330 (*PASSIGNNT+1*)
39340 VAR DEST: UNDRESSP;
39350 BEGIN
39360 WITH TEMP.NAK, STOWEDVAL^.ANCESTOR^ DO
39370 BEGIN
39380 IF FPTWO(PVALUE^) THEN
39390 NASSTCMN(STOWEDVAL);
39400 PVALUE^.OSCOPE := 0;
39410 DEST := INCPTR(PVALUE, POSITION)
39420 END;
39430 DEST^.FIRSTLONG := SOURCE;
39440 NASSTS2 := TEMP.ASNAK;
39450 END;
39460 ()-05*) ()-01*)
39470 (**)
39480 (**)
39490 FUNCTION NASSTPT(TEMP: NAKEGER; SOURCE: OBJECTP): ASNAKED;
39500 (*+01() EXTERN ; ()+01*)
39510 (*-01()
39520 (*PASSIGNNT+2*)
39530 VAR DEST: UNDRESSP;
39540 BEGIN
39550 WITH TEMP.NAK, STOWEDVAL^.ANCESTOR^ DO
39560 BEGIN
39570 IF FPTWO(PVALUE^) THEN
39580 NASSTCMN(STOWEDVAL);
39590 PVALUE^.OSCOPE := 0;
39600 DEST := INCPTR(PVALUE, POSITION)
39610 END;
39620 WITH DEST^ DO
39630 BEGIN
39640 FPINC(SOURCE^);
39650 FPDEC(FIRSTPTR^); IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
39660 FIRSTPTR := SOURCE;
39670 END;
39680 NASSTPT := TEMP.ASNAK;
39690 END;
39700 ()-01*)
39710 FUNCTION SCPNTPT(TEMP: NAKEGER; SOURCE: OBJECTP): ASNAKED;
39720 (*PSCOPENT+2*)
39730 BEGIN
39740 WITH SOURCE^ DO
39750 BEGIN
39760 IF TEMP.NAK.STOWEDVAL^.OSCOPE<OSCOPE THEN ERRORR(RSCOPE);
39770 END;
39780 SCPNTPT := NASSTPT(TEMP, SOURCE);
39790 END;
39800 (**)
39810 (**)
39820 (*-02()
39830 BEGIN
39840 END;
39850 ()-02*)
39860 (*+01()
39870 BEGIN (*OF MAIN PROGRAM*)
39880 END (*OF EVERYTHING*).
39890 ()+01*)

65
lang/a68s/liba68s/newline.p Normal file
View file

@ -0,0 +1,65 @@
79200 #include "rundecs.h"
79210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
79220 (**)
79230 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
79240 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
79250 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
79260 FUNCTION ENSPAGE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
79270 FUNCTION ENSPHYSICALFILE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
79280 (**)
79290 PROCEDURE CLPASC2(P1,P2: IPOINT; PROC: ASPROC); EXTERN;
79300 (**)
79310 (**)
79320 PROCEDURE ERRORSTATE(F:OBJECTP);
79330 (*NOT OPENED OR NOMOOD-ABORT*)
79340 VAR STAT:STATUSSET;
79350 BEGIN STAT:=F^.PCOVER^.STATUS;
79360 IF NOT([OPENED]<=STAT) THEN ERRORR(NOTOPEN)
79370 ELSE IF NOT(([READMOOD]<=STAT) OR ([WRITEMOOD]<=STAT))
79380 THEN ERRORR(NOMOOD);
79390 END;
79400 (**)
79410 (**)
79420 PROCEDURE NEWLINE(RF:OBJECTP);
79430 VAR NSTATUS :STATUSSET; F:OBJECTP;
79440 BEGIN FPINC(RF^);
79450 TESTF(RF,F); NSTATUS:=F^.PCOVER^.STATUS;
79460 IF NOT (([OPENED,READMOOD]<=NSTATUS) OR ([OPENED,WRITEMOOD]<=NSTATUS))
79470 THEN ERRORSTATE(F);
79480 IF [PAGEOVERFLOW]<=NSTATUS
79490 THEN IF NOT ENSPAGE(RF,F) THEN ERRORR(NOLOGICAL);
79500 (* OPENED,LINEOK,MOODOK *)
79510 WITH F^ DO
79520 IF LAZY IN PCOVER^.STATUS THEN WITH PCOVER^ DO
79530 BEGIN
79540 STATUS := STATUS+[NOTINITIALIZED,LFE,PAGEOVERFLOW,LINEOVERFLOW];
79550 LOFCPOS := LOFCPOS+1;
79560 END
79570 ELSE
79580 CLPASC2(ORD(PCOVER), ORD(PCOVER^.BOOK), PCOVER^.DONEWLINE);
79590 WITH RF^ DO BEGIN FDEC; IF FTST THEN GARBAGE(RF) END
79600 END; (* NEWLINE *)
79610 (**)
79620 (**)
79630 PROCEDURE NEWPAGE(RF:OBJECTP);
79640 VAR NSTATUS :STATUSSET; F:OBJECTP;
79650 BEGIN FPINC(RF^);
79660 TESTF(RF,F); NSTATUS:=F^.PCOVER^.STATUS;
79670 IF NOT(([OPENED,READMOOD]<=NSTATUS) OR ([OPENED,WRITEMOOD]<=NSTATUS))
79680 THEN ERRORSTATE(F);
79690 IF (([PFE]<=NSTATUS) OR ([LFE]<=NSTATUS))
79700 THEN IF NOT ENSPHYSICALFILE(RF,F) THEN ERRORR(NOLOGICAL);
79710 WITH F^ DO
79720 CLPASC2(ORD(PCOVER), ORD(PCOVER^.BOOK), PCOVER^.DONEWPAGE);
79730 WITH RF^ DO BEGIN FDEC; IF FTST THEN GARBAGE(RF) END
79740 END; (* NEWPAGE *)
79750 (**)
79760 (**)
79770 (*-02()
79780 BEGIN (*OF A68*)
79790 END; (*OF A68*)
79800 ()-02*)
79810 (*+01()
79820 BEGIN (*OF MAIN PROGRAM*)
79830 END (* OF EVERYTHING *).
79840 ()+01*)

104
lang/a68s/liba68s/onend.p Normal file
View file

@ -0,0 +1,104 @@
79900 #include "rundecs.h"
79910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
79920 (**)
79930 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
79940 PROCEDURE NASSTCMN(ANOBJECT:OBJECTP); EXTERN;
79950 FUNCTION SCPNTPT(TEMP: NAKEGER; SOURCE: OBJECTP): ASNAKED; EXTERN ;
79960 (**)
79970 (**)
79980 PROCEDURE ONLINEEND(RF, ROUTINE: OBJECTP);
79990 VAR TEMP: NAKEGER;
80000 BEGIN
80010 WITH TEMP, NAK DO
80020 BEGIN
80030 (*+11() ASNAK := 0; ()+11*)
80040 STOWEDVAL := RF;
80050 POSITION := RF^.OFFSET+LMOFFSET;
80060 ASNAK := SCPNTPT(TEMP, ROUTINE);
80070 END;
80080 IF FPTST(RF^) THEN GARBAGE(RF)
80090 END;
80100 (**)
80110 (**)
80120 PROCEDURE ONPAGEEND(RF, ROUTINE: OBJECTP);
80130 VAR TEMP: NAKEGER;
80140 BEGIN
80150 WITH TEMP, NAK DO
80160 BEGIN
80170 (*+11() ASNAK := 0; ()+11*)
80180 STOWEDVAL := RF;
80190 POSITION := RF^.OFFSET+PMOFFSET;
80200 ASNAK := SCPNTPT(TEMP, ROUTINE);
80210 END;
80220 IF FPTST(RF^) THEN GARBAGE(RF)
80230 END;
80240 (**)
80250 (**)
80260 PROCEDURE ONPHYSICALFILEEND(RF, ROUTINE: OBJECTP);
80270 VAR TEMP: NAKEGER;
80280 BEGIN
80290 WITH TEMP, NAK DO
80300 BEGIN
80310 (*+11() ASNAK := 0; ()+11*)
80320 STOWEDVAL := RF;
80330 POSITION := RF^.OFFSET+PFMOFFSET;
80340 ASNAK := SCPNTPT(TEMP, ROUTINE);
80350 END;
80360 IF FPTST(RF^) THEN GARBAGE(RF)
80370 END;
80380 (**)
80390 (**)
80400 PROCEDURE ONLOGICALFILEEND(RF, ROUTINE: OBJECTP);
80410 VAR TEMP: NAKEGER;
80420 BEGIN
80430 WITH TEMP, NAK DO
80440 BEGIN
80450 (*+11() ASNAK := 0; ()+11*)
80460 STOWEDVAL := RF;
80470 POSITION := RF^.OFFSET+LFMOFFSET;
80480 ASNAK := SCPNTPT(TEMP, ROUTINE);
80490 END;
80500 IF FPTST(RF^) THEN GARBAGE(RF)
80510 END;
80520 (**)
80530 (**)
80540 PROCEDURE MAKETERM(RF, S: OBJECTP);
80550 VAR T1 (*+01(), T2 ()+01*): TERMSET;
80560 CH: CHAR;
80570 I: INTEGER;
80580 TEMP: NAKEGER;
80590 P: UNDRESSP;
80600 BEGIN T1 := []; (*+01() T2 := []; ()+01*)
80610 WITH S^ DO
80620 FOR I := 1 TO STRLENGTH DO
80630 BEGIN CH := CHARVEC[I];
80640 (*+01() IF ORD(CH) < 59 THEN T1 := T1 + [CH] ELSE T2 := T2 + [ CHR( ORD(CH)-59 ) ] ()+01*)
80650 (*-01() T1 := T1 + [CH] ()-01*)
80660 END;
80670 (*+11() TEMP.ASNAK := 0; ()+11*)
80680 TEMP.NAK.STOWEDVAL := RF;
80690 WITH TEMP, NAK, STOWEDVAL^.ANCESTOR^ DO
80700 BEGIN
80710 POSITION := RF^.OFFSET+TERMOFFSET;
80720 IF FPTWO(PVALUE^) THEN
80730 NASSTCMN(STOWEDVAL);
80740 PVALUE^.OSCOPE := 0;
80750 P := INCPTR(PVALUE, POSITION)
80760 END;
80770 P^.FIRSTTERMSET := T1 ;
80780 (*+01()
80790 P := INCPTR(P, SZWORD);
80800 P^.FIRSTTERMSET := T2;
80810 ()+01*)
80820 IF FPTST(RF^) THEN GARBAGE(RF)
80830 END;
80840 (**)
80850 (**)
80860 (*-02()
80870 BEGIN (*OF A68*)
80880 END; (*OF A68*)
80890 ()-02*)
80900 (*+01()
80910 BEGIN (*OF MAIN PROGRAM*)
80920 END (* OF EVERYTHING *).
80930 ()+01*)

176
lang/a68s/liba68s/openclose.p Normal file
View file

@ -0,0 +1,176 @@
81000 #include "rundecs.h"
81010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
81020 (**)
81030 PROCEDURE ACLOSE(EFET: FETROOMP); EXTERN;
81040 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
81050 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
81060 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
81070 PROCEDURE PCINCR (STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN ;
81080 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN ;
81090 PROCEDURE SETWRITEMOOD(PCOV: OBJECTP); EXTERN;
81100 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
81110 (*+02()
81120 PROCEDURE AOPN(FIL: FETROOMP); EXTERN;
81130 PROCEDURE ACRE(FIL: FETROOMP); EXTERN;
81140 ()+02*)
81150 (**)
81160 (*+01() (*$X6*) ()+01*)
81170 PROCEDURE OPENCOVER(
81180 PFET: FETROOMP; VAR PCOV: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP; L: LFNTYPE) ()-01*)
81190 ); EXTERN;
81200 (*+01() (*$X4*) ()+01*)
81210 (**)
81220 (**)
81230 FUNCTION FUNC68(PB: ASNAKED; RF: OBJECTP): BOOLEAN; EXTERN;
81240 (**)
81250 (**)
81260 (*+02()
81270 PROCEDURE AOPEN (FIL:FETROOMP; DIRECTION:INTEGER; LFN:LFNTYPE; BUF:IPOINT);
81280 VAR NAME: OBJECTP;
81290 BEGIN
81300 IF LFN<>NIL THEN (*NIL FOR STANDOUT/STANDIN, DON'T NEED TO OPEN*)
81310 BEGIN
81320 IF LFN^.STRLENGTH MOD CHARPERWORD = 0 THEN (*NULL CHAR AT END NEEDED*)
81330 BEGIN NAME := CRSTRING(LFN^.STRLENGTH+1);
81340 MOVELEFT(INCPTR(LFN, STRINGCONST), INCPTR(NAME, STRINGCONST), LFN^.STRLENGTH) END
81350 ELSE NAME := LFN;
81360 FPINC(NAME^);
81370 FIL^.FNAME := INCPTR(NAME, STRINGCONST );
81380 IF DIRECTION=FORWRITE THEN ACRE(FIL) ELSE AOPN(FIL);
81390 END;
81400 END;
81410 ()+02*)
81420 (*+05()
81430 PROCEDURE AOPEN( VAR FIL: FYL; DISP:INTEGER; LFN:LFNTYPE; BUF:IPOINT );
81440 PROCEDURE NAMEFILE(CHARVEC: VECCHARS; SU, SL: INTEGER; VAR FIL: ANYFILE); EXTERN;
81450 BEGIN
81460 IF LFN <> NIL THEN
81470 WITH LFN^ DO NAMEFILE(CHARVEC, STRLENGTH, 1, FIL);
81480 IF ODD( DISP DIV FORWRITE ) THEN REWRITE( FIL ) ELSE RESET( FIL )
81490 END ;
81500 ()+05*)
81510 (**)
81520 (**)
81530 (*+01()
81540 PROCEDURE SETLIMIT(VAR FYLE: FYL; LIMIT: INTEGER);
81550 BEGIN LINELIMIT(FYLE, LIMIT) END;
81560 ()+01*)
81570 (**)
81580 (**)
81590 (*+01() (*$X6*) ()+01*)
81600 FUNCTION OPEN(RF,IDF:OBJECTP;PROCEDURE CH (*-01() ( COV: OBJECTP; L: LFNTYPE) ()-01*) ): INTEGER;
81610 VAR I,J,ERRNO: INTEGER;
81620 LFN:LFNTYPE; PFET:FETROOMP;
81630 F, PCOV: OBJECTP;
81640 BEGIN
81650 F := INCPTR(SAFEACCESS(RF), -STRUCTCONST);
81660 PCINCR(INCPTR(F, STRUCTCONST), FILEBLOCK, -INCRF);
81670 (* REMOVE SPACES FROM STRING *)
81680 (*+01()
81690 WITH IDF^ DO
81700 BEGIN FOR I:=1 TO 10 DO
81710 IF CHARVEC[I]=' '
81720 THEN LFN[I]:=':' ELSE LFN[I]:=CHARVEC[I];
81730 IF LFN[8]<>':' THEN
81740 WRITELN('WARNING-FILE NAME MORE THAN 7 CHARS',LFN);
81750 END;
81760 ()+01*)
81770 (*-01() LFN := IDF; ()-01*)
81780 NEW(PFET);
81790 OPENCOVER(PFET, PCOV, LFN, CH);
81800 F^.PCOVER := PCOV;
81810 WITH F^ DO
81820 BEGIN
81830 LOGICALFILEMENDED:=UNDEFIN;
81840 PHYSICALFILEMENDED:=UNDEFIN;
81850 PAGEMENDED:=UNDEFIN;
81860 LINEMENDED:=UNDEFIN;
81870 TERM:=[];
81880 (*+01() TERM1:=[] ; ()+01*)
81890 OPEN := ORD(NOT(OPENED IN PCOVER^.STATUS));
81900 END;
81910 IF FPTST(RF^) THEN GARBAGE(RF);
81920 END; (*OPEN*)
81930 (**)
81940 (**)
81950 (*+01() (*$X6*) ()+01*)
81960 FUNCTION ESTABLISH(
81970 RF,IDF:OBJECTP;PROCEDURE CH (*-01() (COV: OBJECTP; L: LFNTYPE) ()-01*); MP,ML,MC:INTEGER
81980 ): INTEGER;
81990 VAR F:OBJECTP;
82000 BEGIN
82010 IF (MP<1) OR (ML<1) OR (MC<1) THEN ERRORR(POSMIN);
82020 ESTABLISH := OPEN(RF,IDF,CH);
82030 TESTF(RF,F);
82040 WITH F^.PCOVER^ DO
82050 BEGIN
82060 IF NOT([PUTPOSS]<=POSSIBLES) THEN ERRORR(NOWRITE);
82070 IF NOT([ESTABPOSS]<=POSSIBLES) THEN ERRORR(NOESTAB);
82080 IF [GETPOSS]<=POSSIBLES THEN
82090 SETWRITEMOOD(F^.PCOVER);
82100 CHARBOUND:=MC; LINEBOUND:=ML; PAGEBOUND:=MP;
82110 (*+01() SETLIMIT(BOOK, ML*MP); ()+01*)
82120 END
82130 END; (*ESTABLISH*)
82140 (*+01() (*$X4*) ()+01*)
82150 (**)
82160 (**)
82170 PROCEDURE CLOSE(RF:OBJECTP);
82180 VAR F:OBJECTP;
82190 PFET: FETROOMP;
82200 BEGIN TESTF(RF,F);
82210 WITH F^.PCOVER^ DO
82220 BEGIN STATUS:=STATUS-[OPENED];
82230 IF NOT ASSOC THEN
82240 BEGIN
82250 ACLOSE(BOOK);
82260 IF NOT(STARTUP IN STATUS) THEN BEGIN PFET := BOOK; DISPOSE(PFET) END;
82270 END;
82280 END;
82290 IF FPTST(RF^) THEN GARBAGE(RF);
82300 END; (*CLOSE*)
82310 (**)
82320 (**)
82330 (*+24()
82340 PROCEDURE PNTSTAT(COV:OBJECTP);
82350 BEGIN WITH COV^ DO
82360 BEGIN WRITE('STATUS-');
82370 IF [OPENED]<=STATUS THEN WRITE('OPENED ');
82380 IF [LINEOVERFLOW]<=STATUS THEN WRITE('LINEOFLO ');
82390 IF [PAGEOVERFLOW]<=STATUS THEN WRITE('PAGEOFLO ');
82400 IF [PFE]<=STATUS THEN WRITE('PFE ');
82410 IF [LFE]<=STATUS THEN WRITE('LFE ');
82420 IF [READMOOD]<=STATUS THEN WRITE('READMOOD ');
82430 IF [WRITEMOOD]<=STATUS THEN WRITE('WRITEMOOD ');
82440 IF [CHARMOOD]<=STATUS THEN WRITE('CHARMOOD ');
82450 IF [BINMOOD]<=STATUS THEN WRITE('BINMOOD ');
82460 IF [NOTSET]<=STATUS THEN WRITE('NOTSET ');
82470 END;
82480 WRITELN;
82490 END;
82500 (**)
82510 (**)
82520 PROCEDURE PNTPOSS(F:OBJECTP);
82530 BEGIN WRITE('POSSIBLES - ');
82540 WITH F^.PCOVER^ DO
82550 BEGIN IF [RESETPOSS]<=POSSIBLES THEN WRITE('RESETPOSS ');
82560 IF [SETPOSS]<=POSSIBLES THEN WRITE('SETPOSS ');
82570 IF [GETPOSS]<=POSSIBLES THEN WRITE('GETPOSS ');
82580 IF [PUTPOSS]<=POSSIBLES THEN WRITE('PUTPOSS ');
82590 IF [BINPOSS]<=POSSIBLES THEN WRITE('BINPOSS ');
82600 IF [ESTABPOSS]<=POSSIBLES THEN WRITE('ESTABPOSS ');
82610 IF [ASSPOSS]<=POSSIBLES THEN WRITE('ASSPOSS');
82620 END;
82630 WRITELN;
82640 END;
82650 ()+24*)
82660 (**)
82670 (**)
82680 (*-02()
82690 BEGIN (*OF A68*)
82700 END; (*OF A68*)
82710 ()-02*)
82720 (*+01()
82730 BEGIN (*OF MAIN PROGRAM*)
82740 END (* OF EVERYTHING *).
82750 ()+01*)

111
lang/a68s/liba68s/pcollmul.p Normal file
View file

@ -0,0 +1,111 @@
40800 #include "rundecs.h"
40810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
40820 (**)
40830 (**)
40840 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
40850 (**)
40860 (**)
40870 (*+01() (*$X3*) ()+01*)
40880 FUNCTION PCCMN(NEWMULT: OBJECTP; TEMPLATE: DPOINT; ELSIZE: INTEGER): ASNAKED;
40890 VAR TEMP: NAKEGER;
40900 DESCDEX: INTEGER;
40910 NEWELS: OBJECTP;
40920 BEGIN WITH NEWMULT^, TEMP DO WITH NAK DO
40930 BEGIN
40940 MDBLOCK := TEMPLATE;
40950 ENEW(NEWELS, ELSCONST+ELSIZE);
40960 PVALUE := NEWELS;
40970 WITH PVALUE^ DO
40980 BEGIN IHEAD := NIL ;
40990 (*-02() FIRSTWORD := SORTSHIFT * ORD(IELS); PCOUNT := 1; ()-02*)
41000 (*+02() PCOUNT:=1; SORT:=IELS; ()+02*)
41010 OSCOPE := 0; DBLOCK := TEMPLATE; D0 := ELSIZE; CCOUNT := 1 END;
41020 IHEAD := NIL; FPTR := NIL; BPTR := NIL;
41030 (*+11() ASNAK := 0; ()+11*)
41040 STOWEDVAL := NEWMULT; POINTER := INCPTR(PVALUE, ELSCONST);
41050 PCCMN := ASNAK;
41060 END
41070 END;
41080 (**)
41090 (**)
41100 FUNCTION PCOLLR(NOROWS: INTEGER; TEMPLATE: DPOINT): ASNAKED;
41110 (*PPREPROWDISP*)
41120 VAR NEWMULT: OBJECTP;
41130 DESCDEX: INTEGER; ELSIZE, SUM: BOUNDSRANGE;
41140 BEGIN
41150 IF ORD(TEMPLATE)=0 THEN ELSIZE := 1 (*DRESSED*)
41160 ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN ELSIZE := ORD(TEMPLATE) (*UNDRESSED*)
41170 ELSE ELSIZE := TEMPLATE^[0];
41180 ENEW(NEWMULT, MULTCONST+NOROWS*SZPDS);
41190 SUM := -ELSCONST;
41200 WITH NEWMULT^ DO
41210 BEGIN
41220 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
41230 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
41240 (*+01() SECONDWORD := 0; ()+01*)
41250 SIZE := ELSIZE;
41260 FOR DESCDEX := 0 TO NOROWS-1 DO WITH DESCVEC[DESCDEX] DO
41270 BEGIN
41280 UI := GETSTKTOP(SZINT, DESCDEX*SZINT); LI := 1; DI := ELSIZE;
41290 SUM := SUM+ELSIZE; ELSIZE := UI*ELSIZE
41300 END;
41310 LBADJ := SUM;
41320 ROWS := NOROWS-1;
41330 END;
41340 PCOLLR := PCCMN(NEWMULT, TEMPLATE, ELSIZE);
41350 (*THIS WILL NOT WORK THUS ON 16-BITS*)
41360 END;
41370 (**)
41380 (**)
41390 FUNCTION PCOLLRM(NOROWS: INTEGER; TEMPLATE: DPOINT): ASNAKED;
41400 (*PPREPROWDISP+1*)
41410 VAR OLDMULT, NEWMULT: OBJECTP;
41420 DESCDEX, FIRSTROW: INTEGER; ELSIZE, SUM: BOUNDSRANGE;
41430 BEGIN
41440 OLDMULT := ASPTR(GETSTKTOP(SZADDR, NOROWS*SZINT));
41450 WITH OLDMULT^ DO
41460 BEGIN ELSIZE := SIZE;
41470 ENEW(NEWMULT, MULTCONST+(NOROWS+ROWS+1)*SZPDS);
41480 SUM := -ELSCONST;
41490 (*-02() NEWMULT^.FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
41500 (*+02() NEWMULT^.PCOUNT:=0; NEWMULT^.SORT:=MULT; ()+02*)
41510 (*+01() NEWMULT^.SECONDWORD := 0; ()+01*)
41520 NEWMULT^.SIZE := ELSIZE;
41530 FOR DESCDEX := 0 TO ROWS DO WITH DESCVEC[DESCDEX] DO
41540 BEGIN
41550 NEWMULT^.DESCVEC[DESCDEX] := DESCVEC[DESCDEX];
41560 NEWMULT^.DESCVEC[DESCDEX].DI := ELSIZE;
41570 SUM := SUM+LI*ELSIZE; ELSIZE := (UI-LI+1)*ELSIZE;
41580 IF ELSIZE<0 THEN ELSIZE := 0
41590 END
41600 END;
41610 FIRSTROW := OLDMULT^.ROWS+1;
41620 WITH NEWMULT^ DO
41630 BEGIN
41640 FOR DESCDEX := FIRSTROW TO FIRSTROW+NOROWS-1 DO WITH DESCVEC[DESCDEX] DO
41650 BEGIN
41660 UI := GETSTKTOP(SZINT, (DESCDEX-FIRSTROW)*SZINT); LI := 1; DI := ELSIZE;
41670 SUM := SUM+ELSIZE; ELSIZE := UI*ELSIZE
41680 END;
41690 LBADJ := SUM;
41700 ROWS := FIRSTROW+NOROWS-1;
41710 END;
41720 PCOLLRM := PCCMN(NEWMULT, TEMPLATE, ELSIZE);
41730 END;
41740 (*+01() (*$X4*) ()+01*)
41750 (**)
41760 (**)
41770 FUNCTION PCOLLCK(TEMP: NAKEGER; DEPTH, COUNT: INTEGER): ASNAKED;
41780 (*PCOLLCHECK*)
41790 BEGIN
41800 WITH TEMP.NAK.STOWEDVAL^ DO WITH DESCVEC[ROWS-DEPTH] DO
41810 IF (LI<>1) OR (UI<>COUNT) THEN ERRORR(RMULASS);
41820 PCOLLCK := TEMP.ASNAK;
41830 END;
41840 (**)
41850 (**)
41860 (*-02() BEGIN END ; ()-02*)
41870 (*+01()
41880 BEGIN (*OF MAIN PROGRAM*)
41890 END (*OF EVERYTHING*).
41900 ()+01*)

37
lang/a68s/liba68s/pcollst.p Normal file
View file

@ -0,0 +1,37 @@
42000 #include "rundecs.h"
42010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
42020 (**)
42030 (**)
42040 FUNCTION PCOLLST(TEMPLATE: DPOINT): ASNAKED;
42050 (*PPREPSTRDISP*)
42060 VAR TEMP: NAKEGER;
42070 STRUCTSIZE: INTEGER;
42080 NEWSTRUCT: OBJECTP;
42090 BEGIN WITH TEMP.NAK DO
42100 BEGIN
42110 STRUCTSIZE := TEMPLATE^[0]+STRUCTCONST;
42120 (*+11() TEMP.ASNAK := 0; ()+11*)
42130 ENEW(NEWSTRUCT, STRUCTSIZE); POINTER := INCPTR(NEWSTRUCT, STRUCTCONST);
42140 STOWEDVAL := NEWSTRUCT;
42150 WITH NEWSTRUCT^ DO
42160 BEGIN
42170 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
42180 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
42190 LENGTH := STRUCTSIZE; DBLOCK := TEMPLATE
42200 END;
42210 END;
42220 PCOLLST := TEMP.ASNAK;
42230 END;
42240 (*-05()
42250 FUNCTION NAKPTR(NAK: NAKED): OBJECTP;
42260 (*PNAKEDPTR*)
42270 VAR TEMP: NAKEGER;
42280 BEGIN NAKPTR := NAK.STOWEDVAL END;
42290 ()-05*)
42300 (**)
42310 (**)
42320 (*-02() BEGIN END ; ()-02*)
42330 (*+01()
42340 BEGIN (*OF MAIN PROGRAM*)
42350 END (*OF EVERYTHING*).
42360 ()+01*)

47
lang/a68s/liba68s/posenq.p Normal file
View file

@ -0,0 +1,47 @@
82800 #include "rundecs.h"
82810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
82820 (**)
82830 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
82840 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
82850 (*+01() (*$X4*) ()+01*)
82860 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
82870 (**)
82880 (*******POSITION ENQUIRIES*******)
82890 (**)
82900 FUNCTION CHARNUMBER(RF:OBJECTP): INTEGER;
82910 VAR F:OBJECTP;
82920 BEGIN TESTF(RF,F);
82930 WITH F^.PCOVER^ DO
82940 IF [OPENED]<=STATUS THEN CHARNUMBER := COFCPOS
82950 ELSE ERRORR(NOTOPEN);
82960 IF FPTST(RF^) THEN GARBAGE(RF);
82970 END;
82980 (**)
82990 (**)
83000 FUNCTION LINENUMBER(RF:OBJECTP): INTEGER;
83010 VAR F:OBJECTP;
83020 BEGIN TESTF(RF,F);
83030 WITH F^.PCOVER^ DO
83040 IF [OPENED]<=STATUS THEN LINENUMBER := LOFCPOS
83050 ELSE ERRORR(NOTOPEN);
83060 IF FPTST(RF^) THEN GARBAGE(RF);
83070 END;
83080 (**)
83090 (**)
83100 FUNCTION PAGENUMBER(RF:OBJECTP): INTEGER;
83110 VAR F:OBJECTP;
83120 BEGIN TESTF(RF,F);
83130 WITH F^.PCOVER^ DO
83140 IF [OPENED]<=STATUS THEN PAGENUMBER := POFCPOS
83150 ELSE ERRORR(NOTOPEN);
83160 IF FPTST(RF^) THEN GARBAGE(RF);
83170 END;
83180 (**)
83190 (*-02()
83200 BEGIN (*OF A68*)
83210 END; (*OF A68*)
83220 ()-02*)
83230 (*+01()
83240 BEGIN (*OF MAIN PROGRAM*)
83250 END (* OF EVERYTHING *).
83260 ()+01*)

20
lang/a68s/liba68s/powi.c Normal file
View file

@ -0,0 +1,20 @@
POWI(statlink, pow , num)
int *statlink ;
int pow , num ;
{
if ( pow < 0 )
POWNEG() ;
else
{
int n , p , r ;
n = num ; p = pow ;
if ( ( p & 1 ) != 0 ) { r = n; } else { r = 1; }
p >>= 1 ;
while ( p != 0 ) {
n *= n ;
if ( ( p & 1 ) != 0 ) r *= n ;
p >>= 1 ;
}
return( r ) ;
}
}

17
lang/a68s/liba68s/powneg.p Normal file
View file

@ -0,0 +1,17 @@
62600 #include "rundecs.h"
62610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
62620 (**)
62630 (**)
62640 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
62650 (**)
62660 (**)
62670 PROCEDURE POWNEG;
62680 (*CALLED FROM POWE WHEN RAISING INTEGER TO A -VE POWER*)
62690 BEGIN ERRORR(RPOWNEG) END;
62700 (**)
62710 (**)
62720 (*-02() BEGIN END ; ()-02*)
62730 (*+01()
62740 BEGIN (*OF MAIN PROGRAM*)
62750 END (*OF EVERYTHING*).
62760 ()+01*)

23
lang/a68s/liba68s/powr.c Normal file
View file

@ -0,0 +1,23 @@
double POWR(statlink, pow, num)
int *statlink ;
int pow ;
double num ;
{
int p ;
register double n, r;
if (pow < 0) {
p = -pow;
n = 1.0/num;
} else {
p = pow;
n = num;
}
if ( (p & 1) != 0 ) { r = n; } else { r = 1.0; }
p >>= 1;
while ( p != 0 ) {
n *= n;
if ( (p & 1) != 0 ) r *= n;
p >>= 1;
}
return(r) ;
}

88
lang/a68s/liba68s/put.e Normal file
View file

@ -0,0 +1,88 @@
#include "e.h"
exa _1PUTT ; 1st label in PUTT (run68d)
exp $PUT
exp $PRINT
exp $WRITE
exp $PUTT
exp $NXTBIT
exp $STANDOUT
ina jumpdesc
jumpdesc
con 0I SZADDR,0I SZADDR,0I SZADDR ; enough space for 3 pointers
pro $PUT,PUTTVARSPACE
mes 11
loc PUTSTAMP
stl -SZWORD ; set up frame stamp
lxa 0 ; load argument base
lol SZADDR+SZADDR ; load length of data lost, skip static link & space
loc SZADDR+SZADDR+SZWORD
adu SZWORD ; add on space for static link & file pointer & count
ads SZWORD ; add argument base and offset
loi SZADDR ; load file address, objectp
SFL SZADDR ; store in space, left for this reason
lor 1 ; fill in jump info with SP
SFE jumpdesc+SZADDR
lxl 0 ; and LB
SFE jumpdesc+SZADDR+SZADDR
LFE _1PUTT-ENTRYOFFSET ; and code entry point
SFE jumpdesc
gto jumpdesc ; jump to PUTT, in run68d
end PUTTVARSPACE
pro $PRINT,PUTTVARSPACE
mes 11
loc PUTSTAMP
stl -SZWORD ; set up frame stamp
LFE .HTOP-STOUTOFFSET; address of stout in global frame
SFL SZADDR ; store in first param after static link
lor 1 ; fill in jump info with SP
SFE jumpdesc+SZADDR
lxl 0 ; and LB
SFE jumpdesc+SZADDR+SZADDR
LFE _1PUTT-ENTRYOFFSET ; and code entry point
SFE jumpdesc
gto jumpdesc ; jump to PUTT, in run68d
end PUTTVARSPACE
pro $WRITE,PUTTVARSPACE
mes 11
loc PUTSTAMP
stl -SZWORD ; set up frame stamp
LFE .HTOP-STOUTOFFSET; address of stout in global frame
SFL SZADDR ; store in first param after static link
lor 1 ; fill in jump info with SP
SFE jumpdesc+SZADDR
lxl 0 ; and LB
SFE jumpdesc+SZADDR+SZADDR
LFE _1PUTT-ENTRYOFFSET ; and code entry point
SFE jumpdesc
gto jumpdesc ; jump to PUTT, in run68d
end PUTTVARSPACE
pro $NXTBIT,SZWORD ; FUNCTION(VAR N: INTEGER): INTEGER;
loc PASCALSTAMP
stl -SZWORD
LFL SZADDR ; address of N
loi SZWORD
dup SZWORD
loc 1
slu SZWORD ; shift left
LFL SZADDR
sti SZWORD ; replace shifted N
tlt ; test original N
ret SZWORD ; return old top bit of N
end SZWORD
pro $STANDOUT,SZWORD ; call to stoutch (run68d)
loc PASCALSTAMP
stl -SZWORD
LFL SZADDR+SZADDR ; param 1, pcov
LFL SZADDR ; param 2, lfn
LFL 0 ; static link
cal $STOUTCH
asp SZADDR+SZADDR+SZADDR
ret 0
end SZWORD

476
lang/a68s/liba68s/putt.p Normal file
View file

@ -0,0 +1,476 @@
83300 #include "rundecs.h"
83310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
83320 (**)
83330 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN ;
83340 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
83350 PROCEDURE FORMPDESC(OLDESC: OBJECTP; VAR PDESC1: PDESC); EXTERN ;
83360 FUNCTION NEXTEL(I: INTEGER; VAR PDESC1: PDESC): BOOLEAN; EXTERN ;
83370 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
83380 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN ;
83390 FUNCTION GETPROC(RN: OBJECTP): ASNAKED; EXTERN ;
83400 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
83410 FUNCTION ENSLINE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
83420 PROCEDURE ENSSTATE(RF:OBJECTP;VAR F:OBJECTP;READING:STATUSSET); EXTERN;
83430 FUNCTION ENSPAGE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
83440 (**)
83450 PROCEDURE CLPASC1(P1: IPOINT; PROC: ASPROC); EXTERN;
83460 PROCEDURE CLPASC5(P1,P2 :IPOINT; P3,P4 :INTEGER; P5 :IPOINT; PROC: ASPROC); EXTERN;
83470 FUNCTION NXTBIT(VAR N: INTEGER): INTEGER; EXTERN;
83480 (**)
83490 (**)
83500 (*+01() (*$X6*) ()+01*) (*ONLY USED WITH PROC*)
83510 (*+01() FUNCTION TIMESTEN(T, E: INTEGER): REAL ; EXTERN ; ()+01*)
83520 (*+05() FUNCTION TIMESTEN( T: REAL; E: INTEGER ): REAL ; EXTERN ; ()+05*)
83530 (*+01() (*$X4*) ()+01*)
83540 (**)
83550 (**)
83560 FUNCTION SUBFIXED(SIGN, (*0 OR 1 OR -1 FOR SPACE TO BE PROVIDED FOR SIGN*)
83570 BEFORE, (*DIGITS (POSSIBLY SUPPRESSED) REQUIRED BEFORE DECIMAL POINT;
83580 -VE MEANS AS MANY AS NECESSARY*)
83590 POINT, (*0 OR 1 FOR SPACE TO BE PROVIDED FOR DECIMAL POINT*)
83600 AFTER (*DIGITS AFTER DECIMAL POINT*)
83610 : INTEGER;
83620 VAR EXP: INTEGER; (*TO RECEIVE DECIMAL EXPONENT IF EXPNEEDED*)
83630 EXPNEEDED: BOOLEAN;
83640 X: REALTEGER;
83650 R: BOOLEAN; (*TRUE IF X IS REALLY .REAL*)
83660 VAR S: OBJECTP; (*NIL IF A NEW STRING IS TO BE CREATED;
83670 OTHERWISE, A STRING WHOSE CHARVEC IS TO RECEIVE THE RESULT
83680 (AND WHICH MUST BE LONG ENOUGH)*)
83690 START: INTEGER (*FIRST INDEX OF S TO BE USED*)
83700 ): BOOLEAN;
83710 LABEL 999;
83720 CONST POWOF2 = (*+01() 2000000000000000000B; (* 2^55 = 36028797018963968.0 *) ()+01*)
83730 (*TWO TO THE POWER (NO. OF DIGITS IN MANTISSA)+7*)
83740 (*+02() 1.0; ()+02*)
83750 (*+05() 1.0; ()+05*)
83760 POWOF2OVER10 = (*+01() 146314631463146315B; (* ROUND( 2^55 / 10 ) = 3602879701896397.0 *) ()+01*)
83770 (*CAREFULLY ROUNDED UP*)
83780 (*+02() 0.1; ()+02*)
83790 (*+05() 0.1; ()+05*)
83800 (*+44() TYPE MINT = INTEGER; ()+44*)
83810 VAR L, M, BLANKS, PT, FIRSTDIG, INDEX: INTEGER;
83820 A, B, ROUNDD: MINT;
83830 PROCEDURE CONVR(Y(*>=0.0*): REAL; VAR L: INTEGER; VAR A: MINT);
83840 (*COMPUTES L = THE LARGEST NUMBER OF DIGITS BEFORE THE DECIMAL POINT (POSSIBLY NEGATIVE) WHICH MIGHT BE NEEDED;
83850 A = (Y*POWOF2)/10**L (ROUNDED TO NEAREST INTEGER?) *)
83860 (*+01() EXTERN; ()+01*)
83870 (*+05()
83880 CONST LOG10E = 0.43429; (*DELIBERATELY UNDERESTIMATED*)
83890 VAR LL: REAL;
83900 BEGIN
83910 LL :=LN(Y)*LOG10E;
83920 IF LL>0.0 THEN L := 1+TRUNC(LL)
83930 ELSE L := TRUNC(LL);
83940 A := TIMESTEN(Y (* *POWOF2 *), -L);
83950 IF A >= 1.0 THEN
83960 BEGIN L := L+1; A := TIMESTEN(Y (* *POWOF2 *), -L) END;
83970 END ;
83980 ()+05*)
83990 (*+02()
84000 CONST LOG10E = 0.43429; (*DELIBERATELY UNDERESTIMATED*)
84010 VAR LL: REAL;
84020 BEGIN
84030 LL :=LN(Y)*LOG10E;
84040 IF LL>0.0 THEN L := 1+TRUNC(LL)
84050 ELSE L := TRUNC(LL);
84060 A := (*-44() TIMESTE(Y (* *POWOF2 *), -L) ()-44*) (*+44() L ()+44*);
84070 IF A >= 1.0 THEN
84080 BEGIN L := L+1; A := (*-44() TIMESTE(Y (* *POWOF2 *), -L) ()-44*) (*+44() L ()+44*) END;
84090 END ;
84100 ()+02*)
84110 PROCEDURE CONVI(Y(*>=0*): INTEGER; VAR L: INTEGER; VAR A: MINT);
84120 (*AS CONVR, BUT FOR INTEGERS*)
84130 (*+01() EXTERN; ()+01*)
84140 (*+05()
84150 VAR I: INTEGER ; YY: INTEGER ;
84160 BEGIN
84170 YY := Y ;
84180 L := 0 ;
84190 WHILE YY >= 1 DO
84200 BEGIN L := L + 1 ; YY := YY DIV 10 END ;
84210 A := TIMESTEN(Y (* *POWOF2 *), -L)
84220 END ;
84230 ()+05*)
84240 (*+02()
84250 VAR I: INTEGER ; YY: INTEGER ;
84260 BEGIN
84270 YY := Y ;
84280 L := 0 ;
84290 WHILE YY >= 1 DO
84300 BEGIN L := L + 1 ; YY := YY DIV 10 END ;
84310 (*-44() A := TIMESTE(Y (* *POWOF2 *), -L) ()-44*)
84320 (*+44() A := Y; ()+44*)
84330 END ;
84340 ()+02*)
84350 (*-44()
84360 PROCEDURE ROUNDER(DIGITS: INTEGER; VAR ROUNDD: MINT);
84370 (* COMPUTES ROUNDD = 0.5 X ( 10 TO THE POWER OF - DIGITS ) X POWOF2 *)
84380 (*+01() EXTERN; ()+01*)
84390 (*+05()
84400 VAR I : INTEGER ;
84410 BEGIN
84420 IF DIGITS < 0 THEN DIGITS := 0 ELSE IF DIGITS > REALWIDTH THEN DIGITS := REALWIDTH ;
84430 ROUNDD := 1 ;
84440 FOR I := 1 TO DIGITS DO
84450 ROUNDD := ROUNDD / 10 ;
84460 (* ROUNDD = 10 TO THE POWER OF - DIGITS *)
84470 ROUNDD := 0.5 * ROUNDD (* *POWOF2 *);
84480 END ;
84490 ()+05*)
84500 (*+02()
84510 VAR I : INTEGER ;
84520 BEGIN
84530 IF DIGITS < 0 THEN DIGITS := 0 ELSE IF DIGITS > REALWIDTH THEN DIGITS := REALWIDTH ;
84540 ROUNDD := 1 ;
84550 FOR I := 1 TO DIGITS DO
84560 ROUNDD := ROUNDD / 10 ;
84570 (* ROUNDD = 10 TO THE POWER OF - DIGITS *)
84580 ROUNDD := 0.5 * ROUNDD (* *POWOF2 *);
84590 END ;
84600 ()+02*)
84610 ()-44*)
84620 BEGIN (* OF SUBFIXED *)
84630 WITH X DO
84640 BEGIN
84650 IF R THEN IF REA <> 0.0 THEN CONVR(ABS(REA), L, A) ELSE CONVI(ABS(INT), L, A)
84660 ELSE CONVI(ABS(INT), L, A);
84670 (*-44()
84680 IF EXPNEEDED THEN
84690 IF REA<>0.0 THEN
84700 BEGIN
84710 ROUNDER(BEFORE+AFTER, ROUNDD);
84720 B := A; A := A*10;
84730 IF A+ROUNDD<POWOF2 THEN
84740 BEGIN B := A; L := L-1 END;
84750 A := B+ROUNDD;
84760 EXP := L-BEFORE; L := BEFORE
84770 END
84780 ELSE
84790 BEGIN A := 0; EXP := 0 END
84800 ELSE
84810 BEGIN
84820 ROUNDER(L+AFTER, ROUNDD);
84830 A := A+ROUNDD (*+01()+ORD(ROUNDD=0)()+01*);
84840 IF A<POWOF2OVER10 THEN
84850 BEGIN A := A*10; L := L-1 END
84860 END
84870 ()-44*)
84880 END ;
84890 IF L>0 THEN
84900 BEGIN IF BEFORE<0 THEN BEFORE := L; M := L END
84910 ELSE
84920 IF BEFORE<=0 THEN BEGIN BEFORE := ORD(POINT=0); M := BEFORE END ELSE M := 1;
84930 IF (L>BEFORE) OR (AFTER<0) THEN BEGIN SUBFIXED := FALSE; GOTO 999 END;
84940 IF S=NIL THEN S := CRSTRING(SIGN+BEFORE+POINT+AFTER);
84950 BLANKS := START-1+BEFORE-M+ORD(SIGN<0);
84960 WITH S^ DO
84970 BEGIN
84980 FOR INDEX := START TO BLANKS DO
84990 CHARVEC[INDEX] := ' ';
85000 IF SIGN=1 THEN
85010 BEGIN BLANKS := BLANKS+SIGN;
85020 IF (*-44() ( R AND ( X.REA < 0.0 ) ) OR ()-44*)
85030 ( NOT R AND ( X.INT < 0 ) ) THEN
85040 CHARVEC[BLANKS] := '-' ELSE CHARVEC[BLANKS] := '+'
85050 END;
85060 PT := BLANKS+M+1; FIRSTDIG := START+BEFORE+SIGN-L+ORD(L<0);
85070 (*-44()
85080 FOR INDEX := BLANKS+1 TO BLANKS+M+POINT+AFTER DO
85090 IF INDEX=PT THEN CHARVEC[INDEX] := '.'
85100 ELSE IF INDEX<FIRSTDIG THEN CHARVEC[INDEX] := '0'
85110 ELSE
85120 BEGIN
85130 A := A*10;
85140 (*+01()
85150 CHARVEC[INDEX] := CHR( ORD( '0' ) + A DIV POWOF2 ) ;
85160 A := A MOD POWOF2
85170 ()+01*)
85180 (*-01()
85190 L := TRUNC( A (* / POWOF2 *));
85200 CHARVEC[INDEX] := CHR( ORD( '0' ) + L );
85210 A := A - L (* *POWOF2 *);
85220 ()-01*)
85230 END
85240 ()-44*)
85250 (*+44()
85260 FOR INDEX := BLANKS+M+POINT+AFTER DOWNTO BLANKS+1 DO
85270 IF INDEX=PT THEN CHARVEC[INDEX] := '.'
85280 ELSE IF INDEX<FIRSTDIG THEN CHARVEC[INDEX] := '0'
85290 ELSE
85300 BEGIN
85310 B := A MOD 10;
85320 A := A DIV 10;
85330 CHARVEC[INDEX] := CHR( ORD( '0' ) + B );
85340 END;
85350 ()+44*)
85360 END;
85370 SUBFIXED := TRUE;
85380 999:
85390 END;
85400 (**)
85410 (**)
85420 PROCEDURE ERRORFILL(VAR S: OBJECTP; LENGTH: INTEGER);
85430 VAR I: INTEGER;
85440 BEGIN
85450 IF S=NIL THEN S := CRSTRING(LENGTH);
85460 WITH S^ DO
85470 FOR I := 1 TO STRLENGTH DO CHARVEC[I] := ERRORCHAR
85480 END;
85490 (**)
85500 (**)
85510 PROCEDURE PUTT(RF: OBJECTP);
85520 (*+02() LABEL 1; ()+02*)
85530 VAR P: ^REALTEGER;
85540 TEMP: REALTEGER;
85550 PDESC1:PDESC;
85560 TEMPLATE:DPOINT;
85570 COUNT, XMODE, XSIZE, SIZE, I, J: INTEGER;
85580 F,PVAL:OBJECTP;
85590 (**)
85600 (*+02() PROCEDURE DUMMYP; (*JUST HERE TO MAKE 1 GLOBAL, NOT CALLED*)
85610 BEGIN GOTO 1 END; ()+02*)
85620 (**)
85630 PROCEDURE ENSROOM(RF:OBJECTP;VAR F:OBJECTP;UPB:INTEGER);
85640 BEGIN IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
85650 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(NOLOGICAL);
85660 WITH F^.PCOVER^ DO
85670 BEGIN IF COFCPOS+UPB-ORD(COFCPOS<=1)>CHARBOUND
85680 THEN BEGIN IF UPB>=CHARBOUND THEN ERRORR(SMALLLINE);
85690 STATUS:=STATUS+[LINEOVERFLOW];
85700 ENSROOM(RF,F,UPB)
85710 END
85720 ELSE IF COFCPOS<>1 THEN
85730 CLPASC5(ORD(F^.PCOVER), ORD(F), -1, ORD(' '), ORD(BOOK), DOPUTS);
85740 END (*WITH*);
85750 END; (*ENSROOM*)
85760 (**)
85770 PROCEDURE CRREALSTR(R:REAL;VAR S:OBJECTP;START:INTEGER);
85780 VAR E, F: REALTEGER;
85790 NOOK: BOOLEAN;
85800 BEGIN
85810 F.REA := R ;
85820 NOOK:=SUBFIXED(1,1,1,REALWIDTH-1,E.INT,TRUE,F,TRUE,S,START);
85830 S^.CHARVEC[START+REALWIDTH+2]:='E';
85840 NOOK:=SUBFIXED(1,EXPWIDTH,0,0,E.INT,FALSE,E,FALSE,S,START+REALWIDTH+3)
85850 END;
85860 (**)
85870 PROCEDURE VALUEPRINT(RF:OBJECTP;VAR F:OBJECTP);
85880 VAR D,I,J,EXP,UPB,LWB:INTEGER;
85890 S,STR :OBJECTP;
85900 NOOK:BOOLEAN;
85910 BEGIN WITH TEMP DO
85920 BEGIN
85930 UPB:=1;
85940 IF NOT([OPENED,WRITEMOOD,CHARMOOD]<=F^.PCOVER^.STATUS) THEN
85950 ENSSTATE(RF, F, [OPENED,WRITEMOOD,CHARMOOD]);
85960 XSIZE := SZINT;
85970 CASE XMODE OF
85980 -1: (*FILLER*) XSIZE := 0;
85990 (*+61() 1,3,5: (*LONG MODES*)
86000 BEGIN XSIZE := SZLONG; DUMMY END; ()+61*)
86010 0: (*INTEGER*)
86020 BEGIN UPB:=INTSPACE;
86030 ENSROOM(RF,F,UPB);
86040 NOOK:=SUBFIXED(1,INTWIDTH,0,0,EXP,FALSE,TEMP,FALSE,PUTSTRING,1);
86050 WITH F^.PCOVER^ DO CLPASC5(ORD(F^.PCOVER), ORD(PUTSTRING), 1, INTSPACE, ORD(BOOK), DOPUTS)
86060 END;
86070 2: (*REAL*)
86080 BEGIN XSIZE := SZREAL; UPB:=REALSPACE;
86090 ENSROOM(RF,F,UPB);
86100 CRREALSTR(REA,PUTSTRING,1);
86110 WITH F^.PCOVER^ DO CLPASC5(ORD(F^.PCOVER), ORD(PUTSTRING), 1, UPB, ORD(BOOK), DOPUTS);
86120 END;
86130 4: (*COMPL*)
86140 BEGIN UPB:=COMPLSPACE;
86150 ENSROOM(RF,F,UPB);
86160 REA := P^.REA;
86170 CRREALSTR(REA,PUTSTRING,1);
86180 PUTSTRING^.CHARVEC[REALSPACE+1]:=' ';
86190 PUTSTRING^.CHARVEC[REALSPACE+2]:='I';
86200 P:=INCPTR(P, SZREAL); REA := P^.REA;
86210 CRREALSTR(REA,PUTSTRING,REALSPACE+3);
86220 WITH F^.PCOVER^ DO CLPASC5(ORD(F^.PCOVER), ORD(PUTSTRING), 1, UPB, ORD(BOOK), DOPUTS);
86230 END;
86240 7,9,10: BEGIN LWB:=1; (*STRING,BITS,BYTES*)
86250 IF XMODE=7 THEN
86260 BEGIN XSIZE := SZADDR; STR:=PTR; D:=STR^.STRLENGTH;
86270 IF [PAGEOVERFLOW]<=F^.PCOVER^.STATUS
86280 THEN IF NOT ENSPAGE(RF,F) THEN ERRORR(9999)
86290 END
86300 ELSE IF XMODE=9 THEN
86310 BEGIN J:=INT; (*BITS*)
86320 STR := CRSTRING(BITSWIDTH);
86330 WITH STR^ DO
86340 FOR I:=1 TO BITSWIDTH DO
86350 IF NXTBIT(J)=1 THEN CHARVEC[I]:='T' ELSE CHARVEC[I]:='F';
86360 D:=BITSWIDTH
86370 END
86380 ELSE IF XMODE=10 THEN (*BYTES*)
86390 BEGIN STR := CRSTRING(BYTESWIDTH);
86400 WITH STR^ DO
86410 FOR I:=1 TO BYTESWIDTH DO CHARVEC[I]:=ALF[I];
86420 D:=BYTESWIDTH
86430 END;
86440 WHILE LWB<=D DO
86450 BEGIN IF [LINEOVERFLOW]<=F^.PCOVER^.STATUS
86460 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(9999);
86470 WITH F^.PCOVER^ DO
86480 BEGIN UPB:=LWB+CHARBOUND-COFCPOS; (*ROOM LEFT ON LINE*)
86490 IF UPB>D THEN UPB:=D;
86500 WITH F^.PCOVER^ DO CLPASC5(ORD(F^.PCOVER), ORD(STR), LWB, UPB, ORD(BOOK), DOPUTS);
86510 LWB:=UPB+1;
86520 END (*WITH*)
86530 END; (*OD*)
86540 IF XMODE IN [9,10] THEN GARBAGE(STR)
86550 END; (*STRING*)
86560 6,8: (*CHAR, BOOL*)
86570 BEGIN
86580 IF LINEOVERFLOW IN F^.PCOVER^.STATUS THEN
86590 IF NOT ENSLINE(RF, F) THEN ERRORR(9999);
86600 IF XMODE=8 THEN (*BOOL*)
86610 IF (*+01()INT<0()+01*) (*-01()INT<>0()-01*) THEN
86620 INT := ORD('T') ELSE INT := ORD('F');
86630 IF (INT>=0) AND (INT<=MAXABSCHAR) THEN
86640 WITH F^.PCOVER^ DO CLPASC5(ORD(F^.PCOVER), ORD(S), -1, INT, ORD(BOOK), DOPUTS)
86650 ELSE ERRORR(RCHARERROR)
86660 END;
86670 11: (*PROC*) CL68(GETPROC(PTR), RF);
86680 12: (*STRUCT*)
86690 BEGIN J:=0;
86700 REPEAT J:=J+1 UNTIL TEMPLATE^[J]<0;
86710 I:=ORD(P);
86720 WHILE ORD(P)-I<TEMPLATE^[0] DO
86730 BEGIN J:=J+1;
86740 XMODE:=TEMPLATE^[J]-1;
86750 TEMP := P^ ;
86760 VALUEPRINT(RF,F);
86770 P:=INCPTR(P, XSIZE)
86780 END;
86790 XMODE:=12
86800 END;
86810 14: (*CODE(REF FILE)VOID*)
86820 BEGIN
86830 XSIZE := SZPROC;
86840 CLPASC1(ORD(RF), PROCC);
86850 END;
86860 END; (*CASE*)
86870 END (*WITH TEMP*);
86880 END; (*VALUEPRINT*)
86890 (**)
86900 BEGIN (*PUT*)
86910 (*PUTT IS CALLED FROM EITHER PUT OR PRINT, WHICH ARE WRITTEN
86920 IN ASSEMBLER. AT THIS POINT, STKTOP(0) CONTAINS COUNT, THE
86930 SPACE OCCUPIED BY DATA LIST ITEMS, BELOW THAT ARE PAIRS
86940 ON THE STACK, EACH CONSISTING OF AN XMODE AND A VALUE
86950 *)
86960 (*+02() 1: ()+02*) COUNT := GETSTKTOP(SZWORD, 0);
86970 FPINC(RF^);
86980 J := COUNT+SZWORD;
86990 WHILE J>SZWORD DO
87000 BEGIN
87010 J := J-SZWORD;
87020 XMODE := GETSTKTOP(SZWORD, J);
87030 CASE XMODE OF
87040 4,7,11,12,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31:
87050 BEGIN
87060 J := J-SZADDR;
87070 PVAL := ASPTR(GETSTKTOP(SZADDR, J));
87080 FPINC(PVAL^);
87090 END;
87100 (*+61() 1,3,5: J := J-SZLONG; ()+61*)
87110 14: J := J-SZPROC;
87120 2: J := J-SZREAL;
87130 0,6,8,9,10: J := J-SZINT;
87140 -1: (*NO ACTION*);
87150 END;
87160 END;
87170 TESTF(RF,F);
87180 J := COUNT+SZWORD;
87190 WHILE J>SZWORD DO
87200 BEGIN
87210 J := J-SZWORD;
87220 XMODE := GETSTKTOP(SZWORD, J);
87230 IF XMODE>=16 THEN (*ROW*)
87240 BEGIN
87250 J := J-SZADDR;
87260 XMODE:=XMODE-16;
87270 PVAL := ASPTR(GETSTKTOP(SZADDR, J));
87280 WITH PVAL^ DO
87290 BEGIN
87300 FORMPDESC(PVAL,PDESC1);
87310 TEMPLATE:=MDBLOCK;
87320 IF ORD(TEMPLATE)=0 THEN SIZE := SZADDR
87330 ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN SIZE:=ORD(TEMPLATE)
87340 ELSE SIZE:=TEMPLATE^[0];
87350 WHILE NEXTEL(0,PDESC1) DO WITH PDESC1 DO WITH PDESCVEC[0] DO
87360 BEGIN I:=PP;
87370 WHILE I<PP+PSIZE DO
87380 BEGIN P:=INCPTR(PVALUE, I);
87390 TEMP := P^;
87400 VALUEPRINT(RF,F);
87410 I:=I+SIZE
87420 END
87430 END
87440 END
87450 END
87460 ELSE
87470 BEGIN
87480 CASE XMODE OF
87490 4,5,12: (*STRUCT, INCLUDING COMPL*)
87500 BEGIN
87510 J := J-SZADDR;
87520 PVAL := ASPTR(GETSTKTOP(SZADDR, J));
87530 TEMPLATE := PVAL^.DBLOCK;
87540 P := INCPTR(PVAL, STRUCTCONST);
87550 END;
87560 0,6,8,9,10:
87570 BEGIN J := J-SZINT; TEMP.INT := GETSTKTOP(SZINT, J) END;
87580 (*+61()
87590 1,3:
87600 BEGIN J := J-SZLONG; TEMP.LONG := GETSTKTOP(SZLONG, J) END;
87610 ()+61*)
87620 2:
87630 BEGIN J := J-SZREAL; (*-01()TEMP.REA()-01*)(*+01()TEMP.INT()+01*) := GETSTKTOP(SZREAL, J) END;
87640 7,11:
87650 BEGIN J := J-SZADDR; TEMP.PTR := ASPTR(GETSTKTOP(SZADDR, J)) END;
87660 14:
87670 BEGIN J := J-SZPROC; TEMP.PROCC := GETSTKTOP(SZPROC, J) END;
87680 -1: (*NO ACTION*);
87690 END;
87700 VALUEPRINT(RF, F);
87710 END;
87720 END; (*OD*)
87730 J := COUNT+SZWORD;
87740 WHILE J>SZWORD DO
87750 BEGIN
87760 J := J-SZWORD;
87770 XMODE := GETSTKTOP(SZWORD, J);
87780 CASE XMODE OF
87790 4,7,11,12,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31:
87800 BEGIN
87810 J := J-SZADDR;
87820 PVAL := ASPTR(GETSTKTOP(SZADDR, J));
87830 WITH PVAL^ DO
87840 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
87850 END;
87860 (*+61() 1,3,5: J := J-SZLONG; ()+61*)
87870 14: J := J-SZPROC;
87880 2: J := J-SZREAL;
87890 0,6,8,9,10: J := J-SZINT;
87900 -1: (*NO ACTION*);
87910 END;
87920 END;
87930 WITH RF^ DO
87940 BEGIN FDEC; IF FTST THEN GARBAGE(RF) END;
87950 END; (* PUT *)
87960 (**)
87970 (**)
87980 (*-02()
87990 BEGIN (*OF A68*)
88000 END; (*OF A68*)
88010 ()-02*)
88020 (*+01()
88030 BEGIN (*OF MAIN PROGRAM*)
88040 END (* OF EVERYTHING *).
88050 ()+01*)

93
lang/a68s/liba68s/random.p Normal file
View file

@ -0,0 +1,93 @@
65300 #include "rundecs.h"
65310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
65320 (**)
65330 PROCEDURE ERRORR(N: INTEGER);EXTERN;
65340 PROCEDURE GARBAGE(ANOBJECT: OBJECTP);EXTERN;
65350 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
65360 (**)
65370 (**)
65380 FUNCTION RAND(VAR SEED: INTEGER): REAL;
65390 CONST
65400 (*+11()
65410 MULTIPLIER=16777215;
65420 PRIMEMODULUS=281474976710597;
65430 (*N=48, L=24, M=24*)
65440 TWOL=16777216;
65450 TWOM=16777216;
65460 PRIMEDIFF=59; (*2^N - PRIMEMODULUS*)
65470 SHRINKER=4614343880501.61;
65480 STRETCHER=4614343880502.55;
65490 ()+11*)
65500 (*+12()
65510 MULTIPLIER=176;
65520 PRIMEMODULUS=32749;
65530 (*N=15, L=7, M=8*)
65540 TWOL=128;
65550 TWOM=256;
65560 PRIMEDIFF=19; (*2^N - PRIMEMODULUS*)
65570 SHRINKER=1560.381;
65580 STRETCHER=1559.381;
65590 ()+12*)
65600 (*+13()
65610 MULTIPLIER=46340;
65620 PRIMEMODULUS=2147483647;
65630 (*N=31, L=15, M=16*)
65640 TWOL=32768;
65650 TWOM=65536;
65660 PRIMEDIFF=1; (*2^N - PRIMEMODULUS*)
65670 SHRINKER=715827882.334;
65680 STRETCHER=715827881.667;
65690 ()+13*)
65700 VAR HIBITS,MIDBITS,LOBITS: INTEGER;
65710 LSHALFOFRAND: REAL;
65720 BEGIN
65730 SEED := SEED+(1-TRUNC(SEED/SHRINKER));
65740 LSHALFOFRAND := SEED/PRIMEMODULUS;
65750 LSHALFOFRAND := LSHALFOFRAND/PRIMEMODULUS;
65760 LOBITS := SEED MOD TWOL * MULTIPLIER;
65770 MIDBITS := (SEED DIV TWOL - TWOL)*MULTIPLIER + LOBITS DIV TWOL;
65780 IF MIDBITS>=0 THEN
65790 BEGIN
65800 HIBITS := MIDBITS DIV TWOM;
65810 MIDBITS := MIDBITS MOD TWOM + MULTIPLIER*TWOL;
65820 END
65830 ELSE
65840 BEGIN
65850 HIBITS := (MIDBITS+1) DIV TWOM -1;
65860 MIDBITS := MIDBITS MOD TWOM;
65870 MIDBITS := MIDBITS + ORD(MIDBITS<0)*TWOM + MULTIPLIER*TWOL;
65880 (*IN CASE PASCAL COMPILER DOES NOT IMPLEMENT MOD CORRECTLY*)
65890 END;
65900 HIBITS := HIBITS + MIDBITS DIV TWOM;
65910 MIDBITS := MIDBITS MOD TWOM;
65920 LOBITS := LOBITS MOD TWOL + MIDBITS*TWOL;
65930 SEED := LOBITS - PRIMEMODULUS + HIBITS*PRIMEDIFF;
65940 IF SEED<0 THEN SEED := SEED + PRIMEMODULUS;
65950 RAND := SEED/PRIMEMODULUS+LSHALFOFRAND;
65960 SEED := SEED+TRUNC((SEED-1)/STRETCHER)-1
65970 END;
65980 (**)
65990 (**)
66000 FUNCTION RANDOM: REAL;
66010 BEGIN
66020 RANDOM := RAND(LASTRANDOM)
66030 END;
66040 (**)
66050 (**)
66060 FUNCTION NEXTRAN(SEEDP: OBJECTP): REAL;
66070 VAR PTR: UNDRESSP;
66080 BEGIN
66090 PTR := SAFEACCESS(SEEDP);
66100 NEXTRAN := RAND(PTR^.FIRSTWORD);
66110 IF FPTST(SEEDP^) THEN GARBAGE(SEEDP);
66120 END;
66130 (**)
66140 (**)
66150 (*-02()
66160 BEGIN (* OF A68 *)
66170 END (* OF A68 *);
66180 ()-02*)
66190 (*+01()
66200 BEGIN (* OF MAIN PROGRAM *)
66210 END (* OF MAIN PROGRAM *).
66220 ()+01*)

31
lang/a68s/liba68s/rangent.p Normal file
View file

@ -0,0 +1,31 @@
42400 #include "rundecs.h"
42410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
42420 (**)
42430 (**)
42440 (*-01() (*-05()
42450 PROCEDURE RANGENT (IDB: PIDBLK; LOCRG: DEPTHRANGE; NEWRG: PRANGE);
42460 (*PRANGENT*)
42470 BEGIN
42480 WITH NEWRG^ DO WITH FIRSTW DO
42490 BEGIN
42500 LOOPCOUNT := 0;
42510 RGIDBLK := IDB;
42520 RECGEN := NIL;
42530 RGSCOPE := LOCRG;
42540 RIBOFFSET:= FIRSTRG.RIBOFFSET;
42550 (*-41() RGNEXTFREE := INCPTR(NEWRG, RGCONST); ()-41*)
42560 (*+41() RGLASTUSED := ASPTR(ORD(NEWRG)); ()+41*)
42570 END;
42580 FIRSTRG.RIBOFFSET:= NEWRG
42590 END;
42600 ()-05*) ()-01*)
42610 (**)
42620 (**)
42630 (*-02()
42640 BEGIN
42650 END ;
42660 ()-02*)
42670 (*+01()
42680 BEGIN (*OF MAIN PROGRAM*)
42690 END (*OF EVERYTHING*).
42700 ()+01*)

70
lang/a68s/liba68s/rangext.p Normal file
View file

@ -0,0 +1,70 @@
42800 #include "rundecs.h"
42810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
42820 (**)
42830 (**)
42840 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
42850 (**)
42860 (**)
42870 PROCEDURE RANGEXT;
42880 (*PRANGEXT*)
42890 (*+01() EXTERN; ()+01*)
42900 (*+05() EXTERN; ()+05*)
42910 (*-01() (*-05()
42920 VAR LASTRG: PRANGE;
42930 IDP: PIDBLK ;
42940 PP: OBJECTPP ;
42950 I, J: INTEGER;
42960 BEGIN
42970 WITH FIRSTRG.RIBOFFSET^ DO
42980 WITH FIRSTW DO
42990 BEGIN
43000 IDP := RGIDBLK ;
43010 IF FIRSTRG.RIBOFFSET^.RIBOFFSET = FIRSTRG.RIBOFFSET THEN (*PARAMS*)
43020 (*-41() PP := INCPTR(RGNEXTFREE, -PROCBL^.PARAMS) ()-41*)
43030 (*+41() PP := INCPTR(RGLASTUSED, +PROCBL^.PARAMS) ()+41*)
43040 ELSE
43050 (*-41() PP := INCPTR ( FIRSTRG.RIBOFFSET , RGCONST ) ; ()-41*)
43060 (*+41() PP := ASPTR ( ORD( FIRSTRG.RIBOFFSET ) ) ; ()+41*)
43070 FIRSTRG.RIBOFFSET := RIBOFFSET ;
43080 (*-41() WHILE ORD (PP) < ORD (RGNEXTFREE) DO ()-41*)
43090 (*+41() WHILE ORD (PP) > ORD (RGLASTUSED) DO ()+41*)
43100 BEGIN
43110 IDP := INCPTR (IDP , -SZIDBLOCK) ;
43120 WITH IDP^ DO
43130 BEGIN
43140 IF IDSIZE = 0 THEN
43150 BEGIN
43160 (*+41() PP := INCPTR( PP , - SZADDR ) ; ()+41*)
43170 WITH PP^^ DO
43180 BEGIN
43190 FDEC;
43200 IF FTST THEN GARBAGE (PP^)
43210 END ;
43220 (*-41() PP := INCPTR( PP , SZADDR ) ()-41*)
43230 END
43240 ELSE PP := INCPTR( PP , (*+41() - ()+41*) IDSIZE )
43250 END
43260 END
43270 END
43280 END;
43290 (**)
43300 (**)
43310 FUNCTION RANGXTP(ANOBJECT: OBJECTP): OBJECTP;
43320 (*PRANGEXT+2*)
43330 BEGIN
43340 WITH ANOBJECT^ DO FINC;
43350 RANGEXT;
43360 WITH ANOBJECT^ DO FDEC;
43370 RANGXTP := ANOBJECT;
43380 END;
43390 ()-05*) ()-01*)
43400 (**)
43410 (**)
43420 (*-02()
43430 BEGIN
43440 END ;
43450 ()-02*)
43460 (*+01()
43470 BEGIN (*OF MAIN PROGRAM*)
43480 END (*OF EVERYTHING*).
43490 ()+01*)

39
lang/a68s/liba68s/reset.p Normal file
View file

@ -0,0 +1,39 @@
88100 #include "rundecs.h"
88110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
88120 (**)
88130 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
88140 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
88150 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
88160 PROCEDURE SETREADMOOD(PCOV:OBJECTP); EXTERN;
88170 PROCEDURE SETWRITEMOOD(PCOV:OBJECTP); EXTERN;
88180 PROCEDURE SETCHARMOOD(PCOV:OBJECTP); EXTERN;
88190 (**)
88200 (**)
88210 PROCEDURE RESET(RF: OBJECTP);
88220 VAR F: OBJECTP;
88230 BEGIN
88240 TESTF(RF, F);
88250 WITH F^.PCOVER^ DO
88260 IF OPENED IN STATUS THEN
88270 IF RESETPOSS IN POSSIBLES THEN
88280 BEGIN
88290 STATUS := STATUS-[READMOOD,WRITEMOOD,LFE,PFE,PAGEOVERFLOW,LINEOVERFLOW]+[NOTRESET];
88300 COFCPOS := 1; LOFCPOS := 1; POFCPOS := 1;
88310 IF NOT (GETPOSS IN POSSIBLES) THEN SETWRITEMOOD(F^.PCOVER)
88320 ELSE IF NOT (PUTPOSS IN POSSIBLES) THEN SETREADMOOD(F^.PCOVER);
88330 IF NOT (BINPOSS IN POSSIBLES) THEN SETCHARMOOD(F^.PCOVER)
88340 END
88350 ELSE ERRORR(NORESET)
88360 ELSE ERRORR(NOTOPEN);
88370 IF FPTST(RF^) THEN GARBAGE(RF)
88380 END;
88390 (**)
88400 (**)
88410 (*-02()
88420 BEGIN (*OF A68*)
88430 END; (*OF A68*)
88440 ()-02*)
88450 (*+01()
88460 BEGIN (*OF MAIN PROGRAM*)
88470 END (* OF EVERYTHING *).
88480 ()+01*)

47
lang/a68s/liba68s/rnstart.p Normal file
View file

@ -0,0 +1,47 @@
43600 #include "rundecs.h"
43610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
43620 (**)
43630 (**)
43670 (*RNSTART HAD BETTER BE WRITTEN IN ASSEMBLER ON MOST SYSTEMS*)
43680 (**)
43690 (*-01() (*-05()
43700 FUNCTION GETADDRESS (VAR VARIABLE :IPOINT) :IPOINT; EXTERN;
43710 FUNCTION GETCALLER (CALLEE :IPOINT) :IPOINT; EXTERN;
43720 FUNCTION GETLINENO :INTEGER; EXTERN;
43730 PROCEDURE RNSTART;
43740 VAR TSCOPE: DEPTHRANGE;
43750 RNIB: IPOINT;
43760 CURR : INTPOINT ;
43764 PROCEDURE SETNSTATIC( N: INTEGER ) ; EXTERN ;
43770 BEGIN
43780 RNIB := DYNAMIC(ME);
43790 (*+05()SETMYSTATIC(STATIC(DYNAMIC(RNIB)));(*TO ALGOL 68 CALLER*) ()+05*)
43800 (*-05()SETMYSTATIC(GETCALLER(RNIB); ()-05*)
43810 TSCOPE := SCOPE ;
43820 (*+02()LINENO:=GETLINENO;()+02*)
43830 SETMYSTATIC(RNIB); (* TO ALGOL 68 CALLEE *)
43840 (*+05()CURR := ASPTR(RNIB-SZWORD*2);(*CURR IS NOW POINTING TO ALGOL 68 CALLEE'S STATIC LINK*)
43850 CURR ^ := RNIB ; (* SET ALGOL 68 CALLEE'S STATIC LINK TO ITSELF *)
43860 STATICP:=STATICP-192; (*ENABLING ACCESS BY OFFSET FROM PNX R2*)()+05*)
43870 SCOPE := TSCOPE+LOCRG;
43880 LEVEL := PROCBL^.LEVEL;
43890 (*-02()LINENO := 0;()-02*)
43900 WITH FIRSTRG DO WITH FIRSTW DO
43910 BEGIN LOOPCOUNT := 0; RECGEN := NIL; RGIDBLK := PROCBL ^ . IDBLOCK ; RGSCOPE := 1;
43920 RIBOFFSET := INCPTR( ASPTR( RNIB ) , IBCONST + RGCONST );
43930 (*+05()RGLASTUSED :=ASPTR(RNIB-PARAMOFFSET);()+05*)
43940 (*-05()RGLASTUSED:=INCPTR(ASPTR(GETADDRESS(STATICP)),-PARAMOFFSET);()-05*)
43950 END;
43960 IF LEVEL > PROCBL^.SCOPELEVEL + 1 THEN SETNSTATIC( LEVEL - ( PROCBL^.SCOPELEVEL + 1 ) ) ;
43970 END;
43980 ()-05*) ()-01*)
43990 (**)
44000 (**)
44010 (*-02()
44020 BEGIN
44030 END ;
44040 ()-02*)
44050 (*+01()
44060 BEGIN (*OF MAIN PROGRAM*)
44070 END (*OF EVERYTHING*).
44080 ()+01*)

40
lang/a68s/liba68s/routn.p Normal file
View file

@ -0,0 +1,40 @@
44100 #include "rundecs.h"
44110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
44120 (**)
44130 (**)
44140 FUNCTION ROUTNA (PROC:PROCPOINT;ENV:IPOINT):OBJECTP;
44150 VAR NEWRT:OBJECTP;
44160 BEGIN
44170 ENEW(NEWRT, ROUTINESIZE);
44180 WITH NEWRT^ DO
44190 BEGIN
44200 (*-02() FIRSTWORD := SORTSHIFT * ORD(ROUTINE); ()-02*)
44210 (*+02() PCOUNT:=0; SORT:=ROUTINE; ()+02*)
44220 PROCBL:=PROC;
44230 ENVCHAIN:=ENV;
44240 SETMYSTATIC(ENV);
44250 OSCOPE:=SCOPE+PROC^.SCOFFSET;
44260 END;
44270 ROUTNA:= NEWRT
44280 END;
44290 (**)
44300 (**)
44310 FUNCTION ROUTN (PROC: PROCPOINT): OBJECTP;
44320 (* PLOADRT: CONSTRUCTS ROUTINE VALUE FOR GIVEN PROCBL;
44330 RETURNS POINTER TO NEW ROUTINEBLOCK; KK 13.5.1977 *)
44340 VAR I: INTEGER;
44350 BEGIN
44360 FOR I := LEVEL-1 DOWNTO PROC^.SCOPELEVEL DO
44370 SETMYSTATIC( (*-05()STATIC()-05*)(*+05()A68STATIC()+05*) ( STATIC( ME ) ) );
44380 ROUTN := ROUTNA(PROC,STATIC(ME));
44390 END;
44400 (**)
44410 (**)
44420 (*-02()
44430 BEGIN
44440 END ;
44450 ()-02*)
44460 (*+01()
44470 BEGIN (*OF MAIN PROGRAM*)
44480 END (*OF EVERYTHING*).
44490 ()+01*)

28
lang/a68s/liba68s/routnp.p Normal file
View file

@ -0,0 +1,28 @@
44600 #include "rundecs.h"
44610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
44620 (**)
44630 (**)
44640 FUNCTION ROUTNP(PROC: ASPROC; NPARAMS: SIZERANGE):OBJECTP;
44650 VAR NEWRT: OBJECTP;
44660 BEGIN
44670 ENEW(NEWRT, PROUTINESIZE);
44680 WITH NEWRT^ DO
44690 BEGIN
44700 (*-02() FIRSTWORD := SORTSHIFT * ORD(PASCROUT); ()-02*)
44710 (*+02() PCOUNT:=0; SORT:=PASCROUT; ()+02*)
44720 PPROCBL := PROC;
44730 PPARAMS := NPARAMS;
44740 OSCOPE := 1; (*GLOBAL*)
44750 END;
44760 ROUTNP := NEWRT
44770 END;
44780 (**)
44790 (**)
44800 (*-02()
44810 BEGIN
44820 END ;
44830 ()-02*)
44840 (*+01()
44850 BEGIN (*OF MAIN PROGRAM*)
44860 END (*OF EVERYTHING*).
44870 ()+01*)

44
lang/a68s/liba68s/rowm.p Normal file
View file

@ -0,0 +1,44 @@
44900 #include "rundecs.h"
44910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
44920 (**)
44930 (**)
44940 FUNCTION GETMULT(NEWMULT: OBJECTP): OBJECTP; EXTERN;
44950 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
44960 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN ;
44970 PROCEDURE COPYSLICE(ASLICE: OBJECTP); EXTERN ;
44980 (**)
44990 (**)
45000 FUNCTION ROWM(AMULT: OBJECTP; ROWCOUNT: INTEGER): OBJECTP;
45010 (*PROWMULT*)
45020 VAR NEWMULT, OLDESC, NEWDESC: OBJECTP;
45030 I: INTEGER; OLDROWS: 0..7;
45040 BEGIN
45050 WITH AMULT^ DO
45060 BEGIN
45070 IF BPTR<>NIL THEN (*A SLICE*)
45080 COPYSLICE(AMULT);
45090 OLDROWS := ROWS;
45100 ROWS := ROWCOUNT-1;
45110 NEWMULT := COPYDESC(AMULT, MULT);
45120 NEWMULT^.PVALUE := AMULT;
45130 NEWMULT := GETMULT(NEWMULT);
45140 ROWS := OLDROWS;
45150 WITH NEWMULT^ DO
45160 BEGIN
45170 ROWS := ROWCOUNT-1;
45180 FOR I := OLDROWS+1 TO ROWS DO WITH DESCVEC[I] DO
45190 BEGIN LI := 1; UI := 1; DI := PVALUE^.D0 END;
45200 LBADJ := LBADJ+DESCVEC[ROWS].DI*(ROWS-OLDROWS);
45210 FPINC(PVALUE^);
45220 END;
45230 IF FTST THEN GARBAGE(AMULT)
45240 END;
45250 ROWM := NEWMULT;
45260 END;
45270 (**)
45280 (**)
45290 (*-02() BEGIN END ; ()-02*)
45300 (*+01()
45310 BEGIN (*OF MAIN PROGRAM*)
45320 END (*OF EVERYTHING*).
45330 ()+01*)

57
lang/a68s/liba68s/rownm.p Normal file
View file

@ -0,0 +1,57 @@
45400 #include "rundecs.h"
45410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
45420 (**)
45430 (**)
45440 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
45450 PROCEDURE PCINCR (STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN ;
45460 FUNCTION CRMULT( NEWMULT: OBJECTP ; TEMPLATE: DPOINT ) : OBJECTP ; EXTERN ;
45470 (**)
45480 (**)
45490 FUNCTION ROWNM(PVAL: OBJECTP; ROWCOUNT: INTEGER; TEMPLATE: DPOINT): OBJECTP;
45500 (*PROWNONMULT*)
45510 (*WARNING: PVAL CAN ALSO BE AN A68INT; TROUBLE WILL ENSUE IF SZINT>SZADDR*)
45520 VAR NEWMULT: OBJECTP;
45530 DESCDEX: INTEGER;
45540 PTR: UNDRESSP;
45550 BEGIN
45560 ENEW(NEWMULT, MULTCONST+ROWCOUNT*SZPDS);
45570 WITH NEWMULT^ DO
45580 BEGIN
45590 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
45600 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
45610 (*+01() SECONDWORD := 0; ()+01*)
45620 ROWS := ROWCOUNT-1;
45630 FOR DESCDEX := 0 TO ROWCOUNT-1 DO
45640 WITH DESCVEC[DESCDEX] DO
45650 BEGIN LI := 1; UI := 1 END;
45660 IHEAD := NIL; FPTR := NIL; BPTR := NIL
45670 END;
45680 NEWMULT := CRMULT(NEWMULT, TEMPLATE);
45690 PTR := INCPTR(NEWMULT^.PVALUE, ELSCONST);
45700 IF ORD(TEMPLATE)=0 THEN (*DRESSED*)
45710 BEGIN
45720 PTR^.FIRSTPTR := PVAL;
45730 WITH PVAL^ DO FINC
45740 END
45750 ELSE IF ORD(TEMPLATE)=1 THEN (*SIMPLE*)
45760 PTR^.FIRSTINT := ORD(PVAL)
45770 ELSE IF PVAL^.SORT<>UNDEF THEN
45780 BEGIN
45790 IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
45800 MOVELEFT(PVAL, PTR, ORD(TEMPLATE))
45810 ELSE (*STRUCT*)
45820 BEGIN
45830 MOVELEFT(INCPTR(PVAL, STRUCTCONST), PTR, TEMPLATE^[0]);
45840 PCINCR(INCPTR(PVAL, STRUCTCONST), TEMPLATE, +INCRF)
45850 END;
45860 IF FPTST(PVAL^) THEN GARBAGE(PVAL)
45870 END;
45880 ROWNM := NEWMULT;
45890 END;
45900 (**)
45910 (**)
45920 (*-02() BEGIN END ; ()-02*)
45930 (*+01()
45940 BEGIN (*OF MAIN PROGRAM*)
45950 END (*OF EVERYTHING*).
45960 ()+01*)

5
lang/a68s/liba68s/run68g.p Normal file
View file

@ -0,0 +1,5 @@
BEGIN (*of a68*)
END; (*of a68*)
BEGIN (*of m_a_i_n*)
END. (*of everything*)

1801
lang/a68s/liba68s/rundecs.p Normal file
View file

File diff suppressed because it is too large Load diff

346
lang/a68s/liba68s/safeaccess.p Normal file
View file

@ -0,0 +1,346 @@
15000 #include "rundecs.h"
15010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
15020 (**)
15030 (**)
15040 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); EXTERN;
15050 PROCEDURE ERRORR(N: INTEGER); EXTERN;
15060 (**)
15070 (**)
15080 PROCEDURE FORMPDESC(OLDESC: OBJECTP; VAR PDESC1: PDESC);
15090 VAR N: OFFSETRANGE; I, J, K: INTEGER;
15100 BEGIN WITH OLDESC^, PDESC1 DO
15110 BEGIN
15120 PSIZE := SIZE;
15130 ACCOFFS := -ELSCONST;
15140 J := 0;
15150 FOR I := 0 TO ROWS DO WITH DESCVEC[I], PDESCVEC[J] DO
15160 BEGIN
15170 N := UI-LI+1; IF N<0 THEN N := 0;
15180 ACCOFFS := ACCOFFS+LI*DI;
15190 PND := DI*N;
15200 PROWS := J;
15210 IF PSIZE=DI THEN
15220 BEGIN PSIZE := PND; PD := PSIZE END
15230 ELSE
15240 BEGIN J := J+1; PD := DI END;
15250 PL := ELSCONST-LBADJ+ACCOFFS+PND;
15260 PP := PL;
15270 FOR K := PROWS-1 DOWNTO 0 DO WITH PDESCVEC[K] DO
15280 BEGIN PL := PL+LI*DI; PP := PL END;
15290 END;
15300 WITH PDESCVEC[PROWS] DO PP := PL-PND-PD
15310 END
15320 END;
15330 (**)
15340 (**)
15350 FUNCTION NEXTEL(I: INTEGER; VAR PDESC1: PDESC): BOOLEAN;
15360 BEGIN WITH PDESC1 DO WITH PDESCVEC[I] DO
15370 BEGIN
15380 PP := PP+PD;
15390 IF PP<PL THEN
15400 BEGIN
15410 NEXTEL := TRUE
15420 END
15430 ELSE IF I<PROWS THEN
15440 IF NEXTEL(I+1, PDESC1) THEN
15450 BEGIN
15460 PP := PDESCVEC[I+1].PP;
15470 PL := PP+PND;
15480 NEXTEL := TRUE
15490 END
15500 ELSE NEXTEL := FALSE
15510 ELSE
15520 BEGIN
15530 NEXTEL := FALSE;
15540 PP := PL-PND-PD
15550 END
15560 END
15570 END;
15580 (**)
15590 (**)
15600 PROCEDURE PCINCR(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER);
15610 VAR TEMPOS, STRUCTPOS: INTEGER;
15620 PTR: UNDRESSP;
15630 BEGIN
15640 TEMPOS:= 1;
15650 STRUCTPOS:= TEMPLATE^[1];
15660 WHILE STRUCTPOS >= 0
15670 DO BEGIN
15680 PTR := INCPTR(STRUCTPTR, STRUCTPOS);
15690 WITH PTR^ DO
15700 BEGIN
15710 FINCD(FIRSTPTR^,INCREMENT);
15720 IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
15730 END;
15740 TEMPOS:= TEMPOS+1;
15750 STRUCTPOS:= TEMPLATE^[TEMPOS];
15760 END;
15770 END;
15780 (**)
15790 (**)
15800 PROCEDURE PCINCRMULT(ELSPTR:OBJECTP; INCREMENT: INTEGER);
15810 VAR TEMPLATE: DPOINT;
15820 COUNT, ELSIZE: INTEGER;
15830 PTR: UNDRESSP;
15840 BEGIN
15850 TEMPLATE:= ELSPTR^.DBLOCK;
15860 IF ORD(TEMPLATE)<=MAXSIZE (*NOT STRUCT*)
15870 THEN
15880 IF ORD(TEMPLATE)=0 (*DRESSED*)
15890 THEN
15900 BEGIN
15910 PTR := INCPTR(ELSPTR, ELSCONST);
15920 WHILE ORD(PTR)<ORD(ELSPTR)+ELSCONST+ELSPTR^.D0 DO WITH PTR^ DO
15930 BEGIN
15940 FINCD(FIRSTPTR^,INCREMENT);
15950 IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
15960 PTR := INCPTR(PTR, SZADDR);
15970 END
15980 END
15990 ELSE (*NO ACTION*)
16000 ELSE BEGIN (*STRUCT*)
16010 ELSIZE:= TEMPLATE^[0];
16020 IF TEMPLATE^[1]>0
16030 THEN BEGIN
16040 COUNT := ELSPTR^.D0-ELSIZE;
16050 PTR := INCPTR(ELSPTR, ELSCONST);
16060 WHILE COUNT >= 0
16070 DO BEGIN
16080 PCINCR(PTR, TEMPLATE, INCREMENT);
16090 PTR := INCPTR(PTR, ELSIZE);
16100 COUNT:= COUNT-ELSIZE
16110 END;
16120 END;
16130 END;
16140 END;
16150 (**)
16160 (**)
16170 PROCEDURE COPYSLICE(ASLICE: OBJECTP);
16180 VAR NEWSLICE, OLDELS, NEWELS: OBJECTP;
16190 COUNT, SIZEACC, OFFACC: INTEGER;
16200 PDESC1: PDESC;
16210 OLDESCVEC: ARRAY [0..7] OF PDS;
16220 OLDLBADJ: BOUNDSRANGE;
16230 OLDROWS: 0..7;
16240 PROCEDURE CSSUPP(ASLICE: OBJECTP);
16250 VAR LSLICEADJ, COUNT, NCOUNT, NEWDI, ACCOFFS, ACCADJ: INTEGER;
16260 BEGIN
16270 WITH ASLICE^ DO
16280 BEGIN
16290 FPDEC(PVALUE^);
16300 IF FPTST(PVALUE^) THEN GARBAGE(PVALUE);
16310 PVALUE := NEWELS;
16320 FPINC(NEWELS^);
16330 ASLICE := IHEAD;
16340 END;
16350 WHILE ASLICE<>NIL DO WITH ASLICE^ DO
16360 BEGIN
16370 ACCOFFS := -ELSCONST;
16380 FOR COUNT := 0 TO ROWS DO WITH DESCVEC[COUNT] DO
16390 ACCOFFS := ACCOFFS+LI*DI;
16400 LSLICEADJ := ACCOFFS-LBADJ-PDESC1.ACCOFFS+OLDLBADJ;
16410 ACCADJ := 0;
16420 NCOUNT := ROWS;
16430 FOR COUNT := OLDROWS DOWNTO 0 DO WITH OLDESCVEC[COUNT] DO
16440 BEGIN
16450 NEWDI := NEWSLICE^.DESCVEC[COUNT].DI;
16460 ACCADJ := ACCADJ+(LSLICEADJ DIV DI)*NEWDI;
16470 LSLICEADJ := LSLICEADJ MOD DI;
16480 IF NCOUNT>=0 THEN
16490 IF DESCVEC[NCOUNT].DI=DI THEN WITH DESCVEC[NCOUNT] DO
16500 BEGIN
16510 ACCOFFS := ACCOFFS+LI*(NEWDI-DI);
16520 DI := NEWDI;
16530 NCOUNT := NCOUNT-1
16540 END;
16550 END;
16560 LBADJ := ACCOFFS-ACCADJ;
16570 CSSUPP(ASLICE);
16580 ASLICE := FPTR;
16590 END
16600 END;
16610 (**)
16620 BEGIN (*COPYSLICE*)
16630 FORMPDESC(ASLICE, PDESC1);
16640 WITH ASLICE^ DO
16650 BEGIN
16660 OLDELS := PVALUE;
16670 OLDLBADJ := LBADJ;
16680 OLDROWS := ROWS;
16690 SIZEACC:= SIZE;
16700 OFFACC:= -ELSCONST;
16710 FOR COUNT := 0 TO ROWS DO
16720 BEGIN
16730 OLDESCVEC[COUNT] := DESCVEC[COUNT];
16740 WITH DESCVEC[COUNT] DO
16750 BEGIN
16760 DI:= SIZEACC;
16770 SIZEACC := OFFACC+SIZEACC*LI;
16780 OFFACC:= SIZEACC;
16790 SIZEACC:= UI-LI;
16800 IF SIZEACC < 0
16810 THEN SIZEACC:= 0
16820 ELSE SIZEACC:= SIZEACC+1;
16830 SIZEACC:= SIZEACC*DI;
16840 END;
16850 END;
16860 LBADJ := OFFACC;
16870 ENEW(NEWELS, SIZEACC+ELSCONST);
16880 WITH NEWELS^ DO
16890 BEGIN
16900 (*-02() FIRSTWORD := SORTSHIFT*ORD(IELS); ()-02*)
16910 (*+02() PCOUNT:=0; SORT:=IELS; ()+02*)
16920 OSCOPE := 0;
16930 D0 := SIZEACC;
16940 CCOUNT:= 1;
16950 DBLOCK:= OLDELS^.DBLOCK;
16960 IHEAD := NIL;
16970 END;
16980 IF ASLICE=BPTR^.IHEAD THEN
16990 BEGIN
17000 BPTR^.IHEAD:= FPTR;
17010 IF FPTR=NIL THEN
17020 BEGIN FPDEC(BPTR^); IF FPTST(BPTR^) THEN GARBAGE(BPTR) END
17030 END
17040 ELSE BPTR^.FPTR := FPTR;
17050 IF FPTR<>NIL THEN
17060 BEGIN FPTR^.BPTR := BPTR; FPTR := NIL END;
17070 BPTR:= NIL;
17080 END;
17090 COUNT := ELSCONST;
17100 WHILE NEXTEL(0, PDESC1) DO WITH PDESC1 DO WITH PDESCVEC[0] DO
17110 BEGIN
17120 MOVELEFT(INCPTR(OLDELS, PP), INCPTR(NEWELS, COUNT), PSIZE);
17130 COUNT := COUNT+PSIZE;
17140 END;
17150 PCINCRMULT(NEWELS, +INCRF);
17160 NEWSLICE := ASLICE;
17170 CSSUPP(ASLICE);
17180 END;
17190 (**)
17200 (**)
17210 PROCEDURE TESTCC(TARGET: OBJECTP);
17220 LABEL 0000;
17230 VAR DESTREF, LDESC, HEAD, NEWMULT, NEWELS: OBJECTP;
17240 I, CREATIONC, ELSIZE, ACCOFF, LACOFFSET, LACOFF2: INTEGER;
17250 BEGIN
17260 WITH TARGET^.ANCESTOR^ DO
17270 IF PVALUE^.PCOUNT-ORD(PVALUE^.IHEAD<>NIL)>1 THEN
17280 BEGIN
17290 (* PCOUNT > 1 FOR OTHERS BESIDES IHEAD *)
17300 WITH PVALUE^ DO BEGIN
17310 FDEC;
17320 ENEW(NEWELS, D0+ELSCONST)
17330 END;
17340 MOVELEFT(PVALUE, NEWELS, PVALUE^.D0+ELSCONST);
17350 PCINCRMULT(PVALUE, +INCRF);
17360 PVALUE:= NEWELS;
17370 NEWELS^.PCOUNT := 1; (* SORT ALREADY SET*)
17380 NEWELS^.IHEAD := NIL;
17390 CCOUNT := NEWELS^.CCOUNT
17400 END
17410 ELSE
17420 BEGIN
17430 NEWELS := PVALUE;
17440 CREATIONC := NEWELS^.CCOUNT;
17450 DESTREF := TARGET;
17460 IF CREATIONC=TARGET^.CCOUNT THEN GOTO 0000; (*EXIT*)
17470 WITH DESTREF^ DO
17480 IF SORT=REFSL1 THEN
17490 BEGIN
17500 ELSIZE := TARGET^.ANCESTOR^.SIZE; ACCOFF := ELSIZE+OFFSET;
17510 END
17520 ELSE
17530 BEGIN
17540 ELSIZE := PVALUE^.D0;
17550 ACCOFF := ELSIZE-LBADJ;
17560 FOR I := 0 TO ROWS DO WITH DESCVEC[I] DO
17570 ACCOFF := ACCOFF+LI*DI;
17580 (*ACCOFF = DIST FROM START OF ELEMENTS TO 1ST EL BEYOND THIS SLICE*)
17590 END;
17600 (*SLCOPY*)
17610 HEAD := NEWELS^.IHEAD;
17620 WHILE HEAD <> NIL DO WITH HEAD^ DO
17630 BEGIN
17640 LACOFFSET := -LBADJ-ACCOFF;
17650 FOR I := 0 TO ROWS DO WITH DESCVEC[I] DO
17660 LACOFFSET := LACOFFSET+LI*DI;
17670 (*DIST FROM BEYOND LAST EL OF DESTREF TO 1ST EL OF HEAD*)
17680 WITH DESCVEC[ROWS] DO
17690 IF UI < LI THEN
17700 I:= 0
17710 ELSE I := (UI-LI+1)*DI;
17720 LACOFF2 := I+LACOFFSET+ELSIZE;
17730 (*DIST FROM 1ST EL OF DESTREF TO BEYOND LAST EL OF HEAD*)
17740 IF (LACOFFSET>=0) OR (LACOFF2<=0) THEN
17750 HEAD := FPTR
17760 ELSE BEGIN
17770 COPYSLICE(HEAD);
17780 HEAD := NEWELS^.IHEAD;
17790 END;
17800 END;
17810 0000:IF CREATIONC<>0 THEN DESTREF^.CCOUNT := CREATIONC
17820 END
17830 END;
17840 (**)
17850 (**)
17860 PROCEDURE TESTSS (REFSTRUCT: OBJECTP);
17870 (*ASSERT ITS PCOUNT > 1*)
17880 VAR OBJSIZE: INTEGER;
17890 TEMPLATE: DPOINT;
17900 NEWSTRUCT: OBJECTP;
17910 BEGIN
17920 WITH REFSTRUCT^ DO
17930 BEGIN
17940 FPDEC(PVALUE^);
17950 TEMPLATE := PVALUE^.DBLOCK;
17960 OBJSIZE := TEMPLATE^[0];
17970 ENEW(NEWSTRUCT, OBJSIZE+STRUCTCONST);
17980 MOVELEFT(INCPTR(PVALUE, STRUCTCONST), INCPTR(NEWSTRUCT, STRUCTCONST), OBJSIZE);
17990 PCINCR(INCPTR(PVALUE, STRUCTCONST), TEMPLATE, +INCRF);
18000 WITH NEWSTRUCT^ DO
18010 BEGIN
18020 (*-02() FIRSTWORD := SORTSHIFT*ORD(STRUCT); ()-02*)
18030 (*+02() SORT:=STRUCT; ()+02*)
18040 PCOUNT := 1;
18050 LENGTH := REFSTRUCT^.PVALUE^.LENGTH;
18060 DBLOCK:= TEMPLATE
18070 END;
18080 PVALUE:= NEWSTRUCT
18090 END
18100 END;
18110 (**)
18120 (**)
18130 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP;
18140 (* RETURNS A POINTER TO THE REAL PART OF THE STRUCTURE *)
18150 BEGIN
18160 WITH LOCATION^.ANCESTOR^ DO
18170 IF FPTWO(PVALUE^) THEN
18180 CASE SORT OF
18190 REF1: SAFEACCESS := INCPTR(LOCATION,REF1SIZE-SZINT);
18200 (*-01() REF2: SAFEACCESS := INCPTR(LOCATION,REF2SIZE-SZLONG); ()-01*)
18210 CREF: SAFEACCESS := IPTR;
18220 REFR, RECR, RECN, REFN:
18230 BEGIN
18240 IF SORT IN [REFR, RECR] THEN
18250 TESTCC(LOCATION)
18260 ELSE
18270 TESTSS(ANCESTOR);
18280 PVALUE^.OSCOPE := 0;
18290 SAFEACCESS := INCPTR(PVALUE, LOCATION^.OFFSET)
18300 END;
18310 UNDEF: ERRORR(RASSIG);
18320 NILL: ERRORR(RASSIGNIL)
18330 END
18340 ELSE BEGIN
18350 PVALUE^.OSCOPE := 0;
18360 SAFEACCESS := INCPTR(PVALUE,LOCATION^.OFFSET)
18370 END
18380 END;
18390 (**)
18400 (**)
18410 (*-02() BEGIN END ; ()-02*)
18420 (*+01()
18430 BEGIN (*OF MAIN PROGRAM*)
18440 END (*OF EVERYTHING*).
18450 ()+01*)

32
lang/a68s/liba68s/scopext.p Normal file
View file

@ -0,0 +1,32 @@
46000 #include "rundecs.h"
46010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
46020 (**)
46030 (**)
46040 FUNCTION STRUCTSCOPE(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT):DEPTHRANGE; EXTERN;
46050 FUNCTION MULTSCOPE(MULT: OBJECTP):DEPTHRANGE; EXTERN;
46060 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
46070 (**)
46080 (**)
46090 FUNCTION SCOPEXT(SOURCE: OBJECTP): OBJECTP;
46100 (*PSCOPEEXT*)
46110 VAR SOURCESCOPE: DEPTHRANGE;
46120 BEGIN
46130 WITH SOURCE^ DO
46140 IF OSCOPE=0 THEN
46150 IF SORT=STRUCT THEN
46160 BEGIN
46170 SOURCESCOPE := STRUCTSCOPE(INCPTR(SOURCE, STRUCTCONST), DBLOCK);
46180 OSCOPE := SOURCESCOPE
46190 END
46200 ELSE SOURCESCOPE := MULTSCOPE(SOURCE)
46210 ELSE SOURCESCOPE := OSCOPE;
46220 IF SCOPE+FIRSTRG.RIBOFFSET^.RGSCOPE<=SOURCESCOPE THEN ERRORR(RSCOPE);
46230 SCOPEXT := SOURCE;
46240 END;
46250 (**)
46260 (**)
46270 (*-02() BEGIN END ; ()-02*)
46280 (*+01()
46290 BEGIN (*OF MAIN PROGRAM*)
46300 END (*OF EVERYTHING*).
46310 ()+01*)

42
lang/a68s/liba68s/selectr.p Normal file
View file

@ -0,0 +1,42 @@
46400 #include "rundecs.h"
46410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
46420 (**)
46430 (**)
46440 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
46450 FUNCTION GETMULT(NEWMULT: OBJECTP): OBJECTP; EXTERN;
46460 FUNCTION GETSLN(NEWREFSLN:OBJECTP): OBJECTP; EXTERN;
46470 (**)
46480 (**)
46490 FUNCTION SELECTR(AROWED: OBJECTP; TEMPLATE: DPOINT; ROFFSET: INTEGER): OBJECTP;
46500 (*PSELECTROW*)
46510 VAR ADESC: OBJECTP;
46520 BEGIN
46530 WITH AROWED^ DO
46540 IF SORT=MULT THEN
46550 BEGIN
46560 ADESC := COPYDESC(AROWED, MULT);
46570 ADESC^.PVALUE := AROWED;
46580 SELECTR := GETMULT(ADESC);
46590 END
46600 ELSE
46610 BEGIN
46620 ADESC := COPYDESC(AROWED, REFSLN);
46630 ADESC^.PVALUE := AROWED;
46640 SELECTR := GETSLN(ADESC);
46650 END;
46660 WITH ADESC^ DO
46670 BEGIN
46680 MDBLOCK := TEMPLATE;
46690 IF ORD(TEMPLATE)=0 (*DRESSED*) THEN SIZE := 1
46700 ELSE IF ORD(TEMPLATE)<=MAXSIZE (*UNDRESSED*) THEN SIZE := ORD(TEMPLATE)
46710 ELSE (*STRUCT*) SIZE := TEMPLATE^[0];
46720 LBADJ := LBADJ-ROFFSET;
46730 END
46740 END;
46750 (**)
46760 (**)
46770 (*-02() BEGIN END ; ()-02*)
46780 (*+01()
46790 BEGIN (*OF MAIN PROGRAM*)
46800 END (*OF EVERYTHING*).
46810 ()+01*)

44
lang/a68s/liba68s/selecttsn.p Normal file
View file

@ -0,0 +1,44 @@
46900 #include "rundecs.h"
46910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
46920 (**)
46930 (**)
46940 (*-01() (*-05()
46950 FUNCTION SELECTT(PRIMARY: OBJECTP; STRUCTOFF: INTEGER): ASNAKED;
46960 (*PSELECT*)
46970 VAR TEMP: NAKEGER;
46980 BEGIN
46990 WITH TEMP, NAK DO
47000 BEGIN
47010 (*+11() ASNAK := 0; (*TO ENSURE THAT BIT IS CLEAR*) ()+11*)
47020 STOWEDVAL := PRIMARY;
47030 POSITION := STRUCTOFF+PRIMARY^.OFFSET;
47040 SELECTT := ASNAK
47050 END
47060 END;
47070 (**)
47080 (**)
47090 FUNCTION SELECTS(PRIMARY: OBJECTP; STRUCTOFF: INTEGER): ASNAKED;
47100 VAR TEMP: NAKEGER;
47110 BEGIN
47120 WITH TEMP, NAK DO
47130 BEGIN
47140 (*+11() ASNAK := 0; ()+11*) (* TO ENSURE THAT BIT IS CLEAR *)
47150 STOWEDVAL := PRIMARY;
47160 POSITION := STRUCTOFF+STRUCTCONST;
47170 SELECTS := ASNAK
47180 END
47190 END;
47200 (**)
47210 (**)
47220 FUNCTION SELECTN(TEMP: NAKEGER; STRUCTOFF: INTEGER): ASNAKED;
47230 BEGIN WITH TEMP DO
47240 BEGIN NAK.POSITION := NAK.POSITION+STRUCTOFF; SELECTN := ASNAK END;
47250 END;
47260 ()-05*) ()-01*)
47270 (**)
47280 (**)
47290 (*-02() BEGIN END ; ()-02*)
47300 (*+01()
47310 BEGIN (*OF MAIN PROGRAM*)
47320 END (*OF EVERYTHING*).
47330 ()+01*)

23
lang/a68s/liba68s/setcc.p Normal file
View file

@ -0,0 +1,23 @@
47400 #include "rundecs.h"
47410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
47420 (**)
47430 (**)
47440 FUNCTION SETCC(POINT: OBJECTP): OBJECTP;
47450 (*PCREATEREF+4*)
47460 (*A POSSIBLE PROCESS PARAMETER FOR DCL*)
47470 BEGIN
47480 WITH POINT^ DO
47490 IF (SORT=REFSL1) OR (SORT=REFSLN) THEN
47500 CCOUNT := 1; (*SET CCOUNT FOR OVERLAP SEARCH*)
47510 SETCC := POINT;
47520 END;
47530 (**)
47540 (**)
47550 (*-02()
47560 BEGIN
47570 END ;
47580 ()-02*)
47590 (*+01()
47600 BEGIN (*OF MAIN PROGRAM*)
47610 END (*OF EVERYTHING*).
47620 ()+01*)

37
lang/a68s/liba68s/sett.p Normal file
View file

@ -0,0 +1,37 @@
88500 #include "rundecs.h"
88510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
88520 (**)
88530 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
88540 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
88550 PROCEDURE CLPASC5(P1,P2 :IPOINT; P3,P4 :INTEGER; P5 :IPOINT; PROC: ASPROC); EXTERN;
88560 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
88570 (**)
88580 (**)
88590 (*+01() (*$X6*) ()+01*)
88600 PROCEDURE SETT(RF: OBJECTP; P, L, C: INTEGER);
88610 VAR F: OBJECTP;
88620 BEGIN
88630 TESTF(RF, F);
88640 WITH F^.PCOVER^ DO
88650 IF OPENED IN STATUS THEN
88660 IF (P<1) OR (L<1) OR (C<1) THEN ERRORR(POSMIN)
88670 ELSE IF (P>PAGEBOUND+1) OR (L>LINEBOUND+1) OR (C>CHARBOUND+1) THEN ERRORR(POSMAX)
88680 ELSE IF SETPOSS IN POSSIBLES THEN
88690 CLPASC5(ORD(F^.PCOVER), P, L, C, ORD(BOOK), DOSET)
88700 ELSE ERRORR(NOSET)
88710 ELSE ERRORR(NOTOPEN);
88720 IF FPTST(RF^) THEN GARBAGE(RF);
88730 END;
88740 (**)
88750 (**)
88760 (*+01() (*$X4*) ()+01*)
88770 (**)
88780 (**)
88790 (*-02()
88800 BEGIN (*OF A68*)
88810 END; (*OF A68*)
88820 ()-02*)
88830 (*+01()
88840 BEGIN (*OF MAIN PROGRAM*)
88850 END (* OF EVERYTHING *).
88860 ()+01*)

4
lang/a68s/liba68s/shl.c Normal file
View file

@ -0,0 +1,4 @@
SHL(statlink, n , a)
int *statlink ;
unsigned a ;
{ return( n < 0 ? ( - n >= 32 ? 0 : a >> - n ) : n >= 32 ? 0 : a << n ) ; }

4
lang/a68s/liba68s/shr.c Normal file
View file

@ -0,0 +1,4 @@
SHR(statlink, n , a)
int *statlink ;
unsigned a ;
{ return( n < 0 ? ( - n >= 32 ? 0 : a << - n ) : n >= 32 ? 0 : a >> n ) ; }

4
lang/a68s/liba68s/signi.c Normal file
View file

@ -0,0 +1,4 @@
SIGNI(statlink, n)
int *statlink ;
int n ;
{ return( n < 0 ? - 1 : n == 0 ? 0 : 1 ) ; }

4
lang/a68s/liba68s/signr.c Normal file
View file

@ -0,0 +1,4 @@
SIGNR(statlink, n)
int *statlink ;
register double n ;
{ return( n < 0.0 ? - 1 : n == 0.0 ? 0 : 1 ) ; }

4
lang/a68s/liba68s/sin.c Normal file
View file

@ -0,0 +1,4 @@
extern double _sin();
double SIN(statlink, x)
int *statlink; double x;
{return(_sin(x));}

57
lang/a68s/liba68s/skip.p Normal file
View file

@ -0,0 +1,57 @@
47700 #include "rundecs.h"
47710 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
47720 (**)
47730 (**)
47740 PROCEDURE GARBAGE(ANOBJECT: OBJECTP); EXTERN ;
47750 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP; EXTERN;
47760 (**)
47770 (**)
47780 FUNCTION SKIPS: INTEGER;
47790 (*PSKIP*)
47800 BEGIN SKIPS := INTUNDEF END;
47810 (**)
47820 (*-01()
47830 FUNCTION SKIPS2: A68LONG ;
47840 VAR TEMP: REALTEGER ;
47850 BEGIN
47860 WITH TEMP DO
47870 BEGIN
47880 INT := INTUNDEF ;
47890 INT2 := INTUNDEF ;
47900 SKIPS2 := LONG
47910 END
47920 END ;
47930 ()-01*)
47940 (**)
47950 FUNCTION SKIPPIL: OBJECTP;
47960 (*PSKIP+1*)
47970 BEGIN SKIPPIL := UNDEFIN END;
47980 (**)
47990 (**)
48000 FUNCTION SKIPSTR (TEMPLATE: DPOINT):OBJECTP;
48010 (*PSKIPSTRUCT*)
48020 BEGIN SKIPSTR := CRSTRUCT(TEMPLATE) END;
48030 (**)
48040 (**)
48050 FUNCTION NILP: OBJECTP;
48060 (*PNIL*)
48070 BEGIN NILP := NILPTR END;
48080 (**)
48090 (**)
48100 (*-01() (*-05()
48110 PROCEDURE VOID(POINT: OBJECTP);
48120 (*PVOIDNORMAL - USUALLY CODED INLINE*)
48130 BEGIN IF FPTST(POINT^) THEN GARBAGE(POINT) END;
48140 (**)
48150 (**)
48160 PROCEDURE VOIDN(NAK: NAKED);
48170 (*PVOIDNAKED - USUALLY CODED INLINE*)
48180 BEGIN IF FPTST(NAK.STOWEDVAL^) THEN GARBAGE(NAK.STOWEDVAL) END;
48190 ()-05*) ()-01*)
48200 (**)
48210 (**)
48220 (*-02() BEGIN END ; ()-02*)
48230 (*+01()
48240 BEGIN (*OF MAIN PROGRAM*)
48250 END (*OF EVERYTHING*).
48260 ()+01*)

67
lang/a68s/liba68s/slice12.p Normal file
View file

@ -0,0 +1,67 @@
48300 #include "rundecs.h"
48310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
48320 (**)
48330 (**)
48340 PROCEDURE ERRORR(N :INTEGER); EXTERN;
48350 (**)
48360 (**)
48370 PROCEDURE SLCMN(STOWEDVAL: OBJECTP; INDEX, SLICDEX: INTEGER);
48380 BEGIN
48390 WITH STOWEDVAL^ DO CASE SORT OF
48400 MULT, REFSLN, REFR, RECR:
48410 WITH DESCVEC[SLICDEX] DO
48420 BEGIN
48430 IF INDEX<LI THEN ERRORR(RSL1ERROR);
48440 IF INDEX>UI THEN ERRORR(RSL2ERROR);
48450 END;
48460 UNDEF: ERRORR(RSLICE);
48470 NILL: ERRORR(RSLICENIL);
48480 END
48490 END;
48500 (**)
48510 (**)
48520 (*-01() (*-05()
48530 FUNCTION SLICE1(PRIMARY: OBJECTP; INDEX: BOUNDSRANGE): ASNAKED;
48540 (*PSLICE1*)
48550 VAR TEMP: NAKEGER;
48560 BEGIN
48570 WITH TEMP DO WITH NAK DO
48580 BEGIN
48590 STOWEDVAL := PRIMARY;
48600 WITH PRIMARY^ DO WITH DESCVEC[0] DO
48610 IF (INDEX<LI) OR (INDEX>UI) THEN SLCMN(STOWEDVAL, INDEX, 0)
48620 ELSE POSITION := DI*INDEX-LBADJ;
48630 SLICE1 := ASNAK;
48640 END;
48650 END;
48660 (**)
48670 (**)
48680 FUNCTION SLICE2(INDEX1, INDEX2: BOUNDSRANGE): ASNAKED;
48690 (*PSLICE2*)
48700 VAR TEMP: NAKEGER;
48710 OFFS: INTEGER;
48720 BEGIN
48730 WITH TEMP DO WITH NAK DO
48740 BEGIN
48750 (*+11() ASNAK := 0; ()+11*)
48760 STOWEDVAL := ASPTR(GETSTKTOP(SZADDR, 0));
48770 WITH STOWEDVAL^ DO
48780 BEGIN
48790 WITH DESCVEC[0] DO
48800 IF (INDEX2<LI) OR (INDEX2>UI) THEN SLCMN(STOWEDVAL, INDEX2, 0)
48810 ELSE OFFS := -LBADJ+DI*INDEX2;
48820 WITH DESCVEC[1] DO
48830 IF (INDEX1<LI) OR (INDEX1>UI) THEN SLCMN(STOWEDVAL, INDEX1, 1)
48840 ELSE POSITION := OFFS+DI*INDEX1
48850 END;
48860 SLICE2 := ASNAK;
48870 END;
48880 END;
48890 ()-05*) ()-01*)
48900 (**)
48910 (**)
48920 (*-02() BEGIN END ; ()-02*)
48930 (*+01()
48940 BEGIN (*OF MAIN PROGRAM*)
48950 END (*OF EVERYTHING*).
48960 ()+01*)

37
lang/a68s/liba68s/slicen.p Normal file
View file

@ -0,0 +1,37 @@
49000 #include "rundecs.h"
49010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
49020 (**)
49030 (**)
49040 PROCEDURE SLCMN(STOWEDVAL: OBJECTP; INDEX, SLICDEX: INTEGER); EXTERN;
49050 (**)
49060 (**)
49070 FUNCTION SLICEN(INDEX: BOUNDSRANGE; NOROWS: INTEGER): ASNAKED;
49080 (*PSLICEN*)
49090 VAR TEMP: NAKEGER;
49100 OFFS, I: INTEGER;
49110 BEGIN
49120 WITH TEMP DO WITH NAK DO
49130 BEGIN
49140 (*+11() ASNAK := 0; ()+11*)
49150 STOWEDVAL := ASPTR(GETSTKTOP(SZADDR, (NOROWS-1)*SZINT));
49160 WITH STOWEDVAL^ DO
49170 BEGIN
49180 OFFS := -LBADJ;
49190 FOR I := 0 TO NOROWS-1 DO WITH DESCVEC[I] DO
49200 BEGIN
49210 IF (INDEX<LI) OR (INDEX>UI) THEN SLCMN(STOWEDVAL, INDEX, I)
49220 ELSE OFFS := OFFS+DI*INDEX;
49230 INDEX := GETSTKTOP(SZINT, I*SZINT);
49240 END
49250 END;
49260 POSITION := OFFS;
49270 SLICEN := ASNAK;
49280 END;
49290 END;
49300 (**)
49310 (**)
49320 (*-02() BEGIN END ; ()-02*)
49330 (*+01()
49340 BEGIN (*OF MAIN PROGRAM*)
49350 END (*OF EVERYTHING*).
49360 ()+01*)

45
lang/a68s/liba68s/space.p Normal file
View file

@ -0,0 +1,45 @@
88800 #include "rundecs.h"
88810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
88820 (**)
88830 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
88840 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
88850 PROCEDURE CLPASC5(P1,P2 :IPOINT; P3,P4 :INTEGER; P5 :IPOINT; PROC: ASPROC); EXTERN;
88860 PROCEDURE CLRDSTR(PCOV: OBJECTP; VAR CHARS: GETBUFTYPE; TERM (*+01() , TERM1 ()+01*) : TERMSET;
88870 VAR I: INTEGER; BOOK: FETROOMP; PROC: ASPROC); EXTERN;
88880 PROCEDURE TESTF(RF:OBJECTP;VAR F:OBJECTP); EXTERN;
88890 FUNCTION ENSLINE(RF:OBJECTP;VAR F:OBJECTP):BOOLEAN; EXTERN;
88900 PROCEDURE ERRORSTATE(F:OBJECTP); EXTERN;
88910 (**)
88920 (**)
88930 PROCEDURE SPACE(RF:OBJECTP);
88940 VAR NSTATUS :STATUSSET; F,COV:OBJECTP;
88950 CHARS: GETBUFTYPE; I: INTEGER;
88960 BEGIN FPINC(RF^);
88970 TESTF(RF,F); NSTATUS:=F^.PCOVER^.STATUS;
88980 IF NOT(([OPENED,READMOOD]<=NSTATUS) OR ([OPENED,WRITEMOOD]<=NSTATUS))
88990 THEN ERRORSTATE(F)
89000 ELSE IF [LINEOVERFLOW]<=NSTATUS
89010 THEN IF NOT ENSLINE(RF,F) THEN ERRORR(NOLOGICAL);
89020 (* OPENED,LINEOK,MOODOK *)
89030 COV:=F^.PCOVER;
89040 IF COV^.ASSOC THEN WITH COV^ DO
89050 BEGIN
89060 COFCPOS := COFCPOS+1; CPOSELS := CPOSELS+OFFSETDI;
89070 IF COFCPOS>CHARBOUND THEN STATUS := STATUS+[LINEOVERFLOW];
89080 END
89090 ELSE IF [READMOOD,CHARMOOD]<=F^.PCOVER^.STATUS THEN
89100 BEGIN I := -1; CLRDSTR(COV, CHARS, ALLCHAR (*+01() , ALLCHAR ()+01*) , I, COV^.BOOK, COV^.DOGETS) END
89110 ELSE WITH F^.PCOVER^ DO
89120 CLPASC5(ORD(COV), ORD(F), -1, ORD(' '), ORD(BOOK), DOPUTS);
89130 WITH RF^ DO BEGIN FDEC; IF FTST THEN GARBAGE(RF) END;
89140 END;
89150 (**)
89160 (**)
89170 (*-02()
89180 BEGIN (*OF A68*)
89190 END; (*OF A68*)
89200 ()-02*)
89210 (*+01()
89220 BEGIN (*OF MAIN PROGRAM*)
89230 END (* OF EVERYTHING *).
89240 ()+01*)

4
lang/a68s/liba68s/sqrt.c Normal file
View file

@ -0,0 +1,4 @@
extern double _sqrt();
double SQRT(statlink, x)
int *statlink; double x;
{return(_sqt(x));}

Some files were not shown because too many files have changed in this diff Show more