diff --git a/lang/a68s/liba68s/.distr b/lang/a68s/liba68s/.distr new file mode 100644 index 000000000..b05416159 --- /dev/null +++ b/lang/a68s/liba68s/.distr @@ -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 diff --git a/lang/a68s/liba68s/LIST b/lang/a68s/liba68s/LIST new file mode 100644 index 000000000..9d5978206 --- /dev/null +++ b/lang/a68s/liba68s/LIST @@ -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 diff --git a/lang/a68s/liba68s/Makefile b/lang/a68s/liba68s/Makefile new file mode 100644 index 000000000..0529c8bd5 --- /dev/null +++ b/lang/a68s/liba68s/Makefile @@ -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 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 + diff --git a/lang/a68s/liba68s/aclose.c b/lang/a68s/liba68s/aclose.c new file mode 100644 index 000000000..ea0f191a2 --- /dev/null +++ b/lang/a68s/liba68s/aclose.c @@ -0,0 +1,15 @@ +#include + +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); +} + diff --git a/lang/a68s/liba68s/aopen.c b/lang/a68s/liba68s/aopen.c new file mode 100644 index 000000000..c44871a75 --- /dev/null +++ b/lang/a68s/liba68s/aopen.c @@ -0,0 +1,46 @@ +#include +#include + +#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; +} + diff --git a/lang/a68s/liba68s/arctan.c b/lang/a68s/liba68s/arctan.c new file mode 100644 index 000000000..0c1727235 --- /dev/null +++ b/lang/a68s/liba68s/arctan.c @@ -0,0 +1,4 @@ +extern double _atn(); +double ARCTAN(statlink, x) + int *statlink; double x; + {return(_atn(x));} diff --git a/lang/a68s/liba68s/associate.p b/lang/a68s/liba68s/associate.p new file mode 100644 index 000000000..97ad73d88 --- /dev/null +++ b/lang/a68s/liba68s/associate.p @@ -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 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*) diff --git a/lang/a68s/liba68s/calls.e b/lang/a68s/liba68s/calls.e new file mode 100644 index 000000000..9f55a4c6b --- /dev/null +++ b/lang/a68s/liba68s/calls.e @@ -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 diff --git a/lang/a68s/liba68s/catpl.p b/lang/a68s/liba68s/catpl.p new file mode 100644 index 000000000..a8886b1e0 --- /dev/null +++ b/lang/a68s/liba68s/catpl.p @@ -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*) diff --git a/lang/a68s/liba68s/cfstr.p b/lang/a68s/liba68s/cfstr.p new file mode 100644 index 000000000..320e7b9d3 --- /dev/null +++ b/lang/a68s/liba68s/cfstr.p @@ -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)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(LSTRLENGTHRSTRLENGTH); +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*) diff --git a/lang/a68s/liba68s/chains.e b/lang/a68s/liba68s/chains.e new file mode 100644 index 000000000..60a552c53 --- /dev/null +++ b/lang/a68s/liba68s/chains.e @@ -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 diff --git a/lang/a68s/liba68s/cleanup.c b/lang/a68s/liba68s/cleanup.c new file mode 100644 index 000000000..347859553 --- /dev/null +++ b/lang/a68s/liba68s/cleanup.c @@ -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 + +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; +} diff --git a/lang/a68s/liba68s/collp.p b/lang/a68s/liba68s/collp.p new file mode 100644 index 000000000..5fef1fba4 --- /dev/null +++ b/lang/a68s/liba68s/collp.p @@ -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*) diff --git a/lang/a68s/liba68s/colltm.p b/lang/a68s/liba68s/colltm.p new file mode 100644 index 000000000..0f70bcd83 --- /dev/null +++ b/lang/a68s/liba68s/colltm.p @@ -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*) diff --git a/lang/a68s/liba68s/collts.p b/lang/a68s/liba68s/collts.p new file mode 100644 index 000000000..1338fe0f9 --- /dev/null +++ b/lang/a68s/liba68s/collts.p @@ -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*) diff --git a/lang/a68s/liba68s/complex.p b/lang/a68s/liba68s/complex.p new file mode 100644 index 000000000..3598a33d0 --- /dev/null +++ b/lang/a68s/liba68s/complex.p @@ -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*) diff --git a/lang/a68s/liba68s/cos.c b/lang/a68s/liba68s/cos.c new file mode 100644 index 000000000..9ef84fec1 --- /dev/null +++ b/lang/a68s/liba68s/cos.c @@ -0,0 +1,4 @@ +extern double _cos(); +double COS(statlink, x) + int *statlink; double x; + {return(_cos(x));} diff --git a/lang/a68s/liba68s/crmult.p b/lang/a68s/liba68s/crmult.p new file mode 100644 index 000000000..efccb2cba --- /dev/null +++ b/lang/a68s/liba68s/crmult.p @@ -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*) diff --git a/lang/a68s/liba68s/crrefn.p b/lang/a68s/liba68s/crrefn.p new file mode 100644 index 000000000..a70ad94cb --- /dev/null +++ b/lang/a68s/liba68s/crrefn.p @@ -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*) diff --git a/lang/a68s/liba68s/dclpsn.p b/lang/a68s/liba68s/dclpsn.p new file mode 100644 index 000000000..7552d0758 --- /dev/null +++ b/lang/a68s/liba68s/dclpsn.p @@ -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*) diff --git a/lang/a68s/liba68s/div.e b/lang/a68s/liba68s/div.e new file mode 100644 index 000000000..36ca3be4c --- /dev/null +++ b/lang/a68s/liba68s/div.e @@ -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 diff --git a/lang/a68s/liba68s/drefm.p b/lang/a68s/liba68s/drefm.p new file mode 100644 index 000000000..024b0bec6 --- /dev/null +++ b/lang/a68s/liba68s/drefm.p @@ -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*) diff --git a/lang/a68s/liba68s/drefs.p b/lang/a68s/liba68s/drefs.p new file mode 100644 index 000000000..5578dbd64 --- /dev/null +++ b/lang/a68s/liba68s/drefs.p @@ -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*) diff --git a/lang/a68s/liba68s/dumbacch.p b/lang/a68s/liba68s/dumbacch.p new file mode 100644 index 000000000..7eceedc48 --- /dev/null +++ b/lang/a68s/liba68s/dumbacch.p @@ -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*) diff --git a/lang/a68s/liba68s/duminch.p b/lang/a68s/liba68s/duminch.p new file mode 100644 index 000000000..fd790e116 --- /dev/null +++ b/lang/a68s/liba68s/duminch.p @@ -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*) diff --git a/lang/a68s/liba68s/dummy.p b/lang/a68s/liba68s/dummy.p new file mode 100644 index 000000000..75c1f6e0b --- /dev/null +++ b/lang/a68s/liba68s/dummy.p @@ -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*) diff --git a/lang/a68s/liba68s/dumoutch.p b/lang/a68s/liba68s/dumoutch.p new file mode 100644 index 000000000..f7ae2a199 --- /dev/null +++ b/lang/a68s/liba68s/dumoutch.p @@ -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*) diff --git a/lang/a68s/liba68s/e.h b/lang/a68s/liba68s/e.h new file mode 100644 index 000000000..e4c9b427a --- /dev/null +++ b/lang/a68s/liba68s/e.h @@ -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 + diff --git a/lang/a68s/liba68s/ensure.p b/lang/a68s/liba68s/ensure.p new file mode 100644 index 000000000..c8a29a0e3 --- /dev/null +++ b/lang/a68s/liba68s/ensure.p @@ -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*) diff --git a/lang/a68s/liba68s/entier.c b/lang/a68s/liba68s/entier.c new file mode 100644 index 000000000..474ad4778 --- /dev/null +++ b/lang/a68s/liba68s/entier.c @@ -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)) ; + } diff --git a/lang/a68s/liba68s/errorr.p b/lang/a68s/liba68s/errorr.p new file mode 100644 index 000000000..2fffba837 --- /dev/null +++ b/lang/a68s/liba68s/errorr.p @@ -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-I0 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+LOCRGNIL 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*) diff --git a/lang/a68s/liba68s/exit.c b/lang/a68s/liba68s/exit.c new file mode 100644 index 000000000..b1f73107f --- /dev/null +++ b/lang/a68s/liba68s/exit.c @@ -0,0 +1,14 @@ +#include + +cleenup() + { + register FILE *iop ; + extern FILE *_lastbuf ; + + for ( iop = _iob ; iop < _lastbuf ; iop ++ ) + fclose( iop ) ; + } + +exit(n) +int n; + { cleenup() ; _exit(n) ; } diff --git a/lang/a68s/liba68s/exp.c b/lang/a68s/liba68s/exp.c new file mode 100644 index 000000000..406ca0f16 --- /dev/null +++ b/lang/a68s/liba68s/exp.c @@ -0,0 +1,4 @@ +extern double _exp(); +double EXP(statlink, x) + int *statlink; double x; + {return(_exp(x));} diff --git a/lang/a68s/liba68s/fixed.p b/lang/a68s/liba68s/fixed.p new file mode 100644 index 000000000..e0c5001b6 --- /dev/null +++ b/lang/a68s/liba68s/fixed.p @@ -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*) diff --git a/lang/a68s/liba68s/float.p b/lang/a68s/liba68s/float.p new file mode 100644 index 000000000..84f45d837 --- /dev/null +++ b/lang/a68s/liba68s/float.p @@ -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*) diff --git a/lang/a68s/liba68s/genrec.p b/lang/a68s/liba68s/genrec.p new file mode 100644 index 000000000..aad14c304 --- /dev/null +++ b/lang/a68s/liba68s/genrec.p @@ -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*) diff --git a/lang/a68s/liba68s/get.e b/lang/a68s/liba68s/get.e new file mode 100644 index 000000000..2849d62f3 --- /dev/null +++ b/lang/a68s/liba68s/get.e @@ -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 + diff --git a/lang/a68s/liba68s/getaddr.e b/lang/a68s/liba68s/getaddr.e new file mode 100644 index 000000000..be2555a64 --- /dev/null +++ b/lang/a68s/liba68s/getaddr.e @@ -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 diff --git a/lang/a68s/liba68s/getmult.p b/lang/a68s/liba68s/getmult.p new file mode 100644 index 000000000..db2f396e5 --- /dev/null +++ b/lang/a68s/liba68s/getmult.p @@ -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*) diff --git a/lang/a68s/liba68s/getout.p b/lang/a68s/liba68s/getout.p new file mode 100644 index 000000000..aca36d41e --- /dev/null +++ b/lang/a68s/liba68s/getout.p @@ -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 (NECLEVME)()+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*) diff --git a/lang/a68s/liba68s/gett.p b/lang/a68s/liba68s/gett.p new file mode 100644 index 000000000..5dd61eed4 --- /dev/null +++ b/lang/a68s/liba68s/gett.p @@ -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 RINT0) 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 RINT1) 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)-ISZWORD 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=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*) diff --git a/lang/a68s/liba68s/global.p b/lang/a68s/liba68s/global.p new file mode 100644 index 000000000..c7bacca51 --- /dev/null +++ b/lang/a68s/liba68s/global.p @@ -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)= 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*) diff --git a/lang/a68s/liba68s/globale.e b/lang/a68s/liba68s/globale.e new file mode 100644 index 000000000..a9fb457c0 --- /dev/null +++ b/lang/a68s/liba68s/globale.e @@ -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 + diff --git a/lang/a68s/liba68s/gtot.p b/lang/a68s/liba68s/gtot.p new file mode 100644 index 000000000..82bee26a4 --- /dev/null +++ b/lang/a68s/liba68s/gtot.p @@ -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*) diff --git a/lang/a68s/liba68s/gtotref.p b/lang/a68s/liba68s/gtotref.p new file mode 100644 index 000000000..3049f346f --- /dev/null +++ b/lang/a68s/liba68s/gtotref.p @@ -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*) diff --git a/lang/a68s/liba68s/gvasstx.p b/lang/a68s/liba68s/gvasstx.p new file mode 100644 index 000000000..6b464142a --- /dev/null +++ b/lang/a68s/liba68s/gvasstx.p @@ -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*) diff --git a/lang/a68s/liba68s/gvscope.p b/lang/a68s/liba68s/gvscope.p new file mode 100644 index 000000000..3a9f652eb --- /dev/null +++ b/lang/a68s/liba68s/gvscope.p @@ -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+LOCRGRELSUP(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*) diff --git a/lang/a68s/liba68s/linit2.p b/lang/a68s/liba68s/linit2.p new file mode 100644 index 000000000..5086bd1e7 --- /dev/null +++ b/lang/a68s/liba68s/linit2.p @@ -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*) diff --git a/lang/a68s/liba68s/linit34.p b/lang/a68s/liba68s/linit34.p new file mode 100644 index 000000000..73d8303ee --- /dev/null +++ b/lang/a68s/liba68s/linit34.p @@ -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*) diff --git a/lang/a68s/liba68s/linitinc.p b/lang/a68s/liba68s/linitinc.p new file mode 100644 index 000000000..c484adb29 --- /dev/null +++ b/lang/a68s/liba68s/linitinc.p @@ -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*) diff --git a/lang/a68s/liba68s/ln.c b/lang/a68s/liba68s/ln.c new file mode 100644 index 000000000..57aec0367 --- /dev/null +++ b/lang/a68s/liba68s/ln.c @@ -0,0 +1,5 @@ +extern double _ln(); + +double LN(statlink, x) + int *statlink; double x; + {return(_ln(x));} diff --git a/lang/a68s/liba68s/make b/lang/a68s/liba68s/make new file mode 100755 index 000000000..7004787a4 --- /dev/null +++ b/lang/a68s/liba68s/make @@ -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 ;; \ diff --git a/lang/a68s/liba68s/maxr.c b/lang/a68s/liba68s/maxr.c new file mode 100644 index 000000000..8f5ead0b1 --- /dev/null +++ b/lang/a68s/liba68s/maxr.c @@ -0,0 +1,14 @@ +#include + +double MAXR(staticlink) + int *staticlink; +#ifdef MAXFLOAT + { return(MAXFLOAT); } +#else +#ifdef HUGE + { return(HUGE); } +#else + { return(0.0); /* obviously wrong*/ } +#endif +#endif + diff --git a/lang/a68s/liba68s/mod.c b/lang/a68s/liba68s/mod.c new file mode 100644 index 000000000..4b51aa3b9 --- /dev/null +++ b/lang/a68s/liba68s/mod.c @@ -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 ) ; + } diff --git a/lang/a68s/liba68s/mulis.p b/lang/a68s/liba68s/mulis.p new file mode 100644 index 000000000..afae875cf --- /dev/null +++ b/lang/a68s/liba68s/mulis.p @@ -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*) diff --git a/lang/a68s/liba68s/nassp.p b/lang/a68s/liba68s/nassp.p new file mode 100644 index 000000000..5a2a0dbbf --- /dev/null +++ b/lang/a68s/liba68s/nassp.p @@ -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^.OSCOPENIL 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*) diff --git a/lang/a68s/liba68s/pcollmul.p b/lang/a68s/liba68s/pcollmul.p new file mode 100644 index 000000000..6f1ed6d05 --- /dev/null +++ b/lang/a68s/liba68s/pcollmul.p @@ -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*) diff --git a/lang/a68s/liba68s/pcollst.p b/lang/a68s/liba68s/pcollst.p new file mode 100644 index 000000000..3be37cf17 --- /dev/null +++ b/lang/a68s/liba68s/pcollst.p @@ -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*) diff --git a/lang/a68s/liba68s/posenq.p b/lang/a68s/liba68s/posenq.p new file mode 100644 index 000000000..eaf3c5557 --- /dev/null +++ b/lang/a68s/liba68s/posenq.p @@ -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*) diff --git a/lang/a68s/liba68s/powi.c b/lang/a68s/liba68s/powi.c new file mode 100644 index 000000000..0e38c45ca --- /dev/null +++ b/lang/a68s/liba68s/powi.c @@ -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 ) ; + } + } diff --git a/lang/a68s/liba68s/powneg.p b/lang/a68s/liba68s/powneg.p new file mode 100644 index 000000000..380b3bb49 --- /dev/null +++ b/lang/a68s/liba68s/powneg.p @@ -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*) diff --git a/lang/a68s/liba68s/powr.c b/lang/a68s/liba68s/powr.c new file mode 100644 index 000000000..e93648dfa --- /dev/null +++ b/lang/a68s/liba68s/powr.c @@ -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) ; + } diff --git a/lang/a68s/liba68s/put.e b/lang/a68s/liba68s/put.e new file mode 100644 index 000000000..40a818bf6 --- /dev/null +++ b/lang/a68s/liba68s/put.e @@ -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 + diff --git a/lang/a68s/liba68s/putt.p b/lang/a68s/liba68s/putt.p new file mode 100644 index 000000000..2d2a701ca --- /dev/null +++ b/lang/a68s/liba68s/putt.p @@ -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+ROUNDD0 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 INDEXCHARBOUND +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)-ISZWORD 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 ISZWORD 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*) diff --git a/lang/a68s/liba68s/random.p b/lang/a68s/liba68s/random.p new file mode 100644 index 000000000..a94dc44df --- /dev/null +++ b/lang/a68s/liba68s/random.p @@ -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*) diff --git a/lang/a68s/liba68s/rangent.p b/lang/a68s/liba68s/rangent.p new file mode 100644 index 000000000..4f8c90cfd --- /dev/null +++ b/lang/a68s/liba68s/rangent.p @@ -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*) diff --git a/lang/a68s/liba68s/rangext.p b/lang/a68s/liba68s/rangext.p new file mode 100644 index 000000000..ccee070ba --- /dev/null +++ b/lang/a68s/liba68s/rangext.p @@ -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*) diff --git a/lang/a68s/liba68s/reset.p b/lang/a68s/liba68s/reset.p new file mode 100644 index 000000000..ae271aa48 --- /dev/null +++ b/lang/a68s/liba68s/reset.p @@ -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*) diff --git a/lang/a68s/liba68s/rnstart.p b/lang/a68s/liba68s/rnstart.p new file mode 100644 index 000000000..fddd5d702 --- /dev/null +++ b/lang/a68s/liba68s/rnstart.p @@ -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*) diff --git a/lang/a68s/liba68s/routn.p b/lang/a68s/liba68s/routn.p new file mode 100644 index 000000000..c267b96a7 --- /dev/null +++ b/lang/a68s/liba68s/routn.p @@ -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*) diff --git a/lang/a68s/liba68s/routnp.p b/lang/a68s/liba68s/routnp.p new file mode 100644 index 000000000..6cf2e3a75 --- /dev/null +++ b/lang/a68s/liba68s/routnp.p @@ -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*) diff --git a/lang/a68s/liba68s/rowm.p b/lang/a68s/liba68s/rowm.p new file mode 100644 index 000000000..86cbc6743 --- /dev/null +++ b/lang/a68s/liba68s/rowm.p @@ -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*) diff --git a/lang/a68s/liba68s/rownm.p b/lang/a68s/liba68s/rownm.p new file mode 100644 index 000000000..392ded6e2 --- /dev/null +++ b/lang/a68s/liba68s/rownm.p @@ -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*) diff --git a/lang/a68s/liba68s/run68g.p b/lang/a68s/liba68s/run68g.p new file mode 100644 index 000000000..58a680a73 --- /dev/null +++ b/lang/a68s/liba68s/run68g.p @@ -0,0 +1,5 @@ +BEGIN (*of a68*) +END; (*of a68*) + +BEGIN (*of m_a_i_n*) +END. (*of everything*) diff --git a/lang/a68s/liba68s/rundecs.p b/lang/a68s/liba68s/rundecs.p new file mode 100644 index 000000000..b899c1333 --- /dev/null +++ b/lang/a68s/liba68s/rundecs.p @@ -0,0 +1,1801 @@ +0000 # +0001 (*+02() +0002 #define FINC PCOUNT := PCOUNT+1 +0003 #define FDEC PCOUNT := PCOUNT-1 +0004 #define FTST PCOUNT<1 +0006 #define FPINC(THISP)THISP.PCOUNT := THISP.PCOUNT+1 +0007 #define FPDEC(THISP)THISP.PCOUNT := THISP.PCOUNT-1 +0008 #define FPTST(THISP)THISP.PCOUNT<1 +0009 #define FPTWO(THISP)THISP.PCOUNT>=2 +0010 #define FINCD(THISP,I)THISP.PCOUNT := THISP.PCOUNT+I +0011 ()+02*) +0012 (*+01() +0013 #define FINC FIRSTWORD := FIRSTWORD+INCRF +0014 #define FDEC FIRSTWORD := FIRSTWORD-INCRF; +0015 #define FTST FIRSTWORDTWOF +0020 #define FINCD(THISP,I))THISP.FIRSTWORD := THISP.FIRSTWORD+I +0021 ()+01*) +0022 (*+05() +0023 #define FINC FIRSTWORD := FIRSTWORD+INCRF +0024 #define FDEC FIRSTWORD := FIRSTWORD-INCRF; +0025 #define FTST FIRSTWORDTWOF +0030 #define FINCD(THISP,I))THISP.FIRSTWORD := THISP.FIRSTWORD+I +0031 ()+05*) +00100 (*+01() (*$L-*) ()+01*) +00110 (*+02() (*$U+*)(*$W-*)(*$G-*)(*$D+*)(*$R-*)(*$L+*)(*$E+*) ()+02*) +00120 (*+02() (*$I32*) (* MAKE SETS ABLE TO HOLD 32 BITS *) ()+02*) +00150 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +00200 (**) +00250 (*+01() +00300 (*-52() PROGRAM RA68 (INPUT/+,OUTPUT+/); ()-52*) +00350 (*+52() PROGRAM RA68 (INPUT+,OUTPUT+/); ()+52*) +00400 (*$G-,P-,T-,W2000 OPTIONS: COMPILE ONLY, NO IMMEDIATE GO, +00450 SET SIZE OF STACK/HEAP +00500 NO POINTER CHECK; ^'S TAKE UP 17 BITS *) +00550 ()+01*) +00555 (*+02() +00560 (*+71() PROGRAM RUN68 (INPUT,OUTPUT); ()+71*) +00565 ()+02*) +00600 (*+03() +00650 (*$E+;D-;NL*) +00700 PROGRAM RUN68; +00750 ()+03*) +00800 (**) +00850 (**) +00900 CONST (* CONST CONST CONST CONST CONST CONST CONST*) +00950 (**) +01000 (**************) +01050 (* WORD SIZES *) +01100 (**************) +01150 (**) +01200 (*+01() +01250 SZWORD=1; SZADDR=1; SZINT=1; SZREAL=1; SZLONG=2; SZNAK=1; SZPDS=1; SZPROC=1; SZTERMSET=2; +01300 CHARPERWORD=10 ; SZIDBLOCK=1 ; +01350 (*-41() STACKSZWORD = 1 ; STACKSZADDR = 1 ; STACKSZINT = 1 ; ()-41*) +01400 ()+01*) +01450 (*+02() +01500 (*+12() (*-19() +01550 SZWORD=2; SZADDR=2; SZINT=2; SZREAL=4; SZLONG=4; SZNAK=4; SZPDS=6; SZPROC=2; SZTERMSET=16; +01600 CHARPERWORD=2 ; SZIDBLOCK=12; +01650 (*-41() STACKSZWORD = 2 ; STACKSZADDR = 2 ; STACKSZINT = 2 ; ()-41*) +01700 ()-19*) +01705 (*+19() +01710 SZWORD=2; SZADDR=4; SZINT=2; SZREAL=8; SZLONG=4; SZNAK=4; SZPDS=6; SZPROC=8; SZTERMSET=16; +01720 CHARPERWORD=2 ; SZIDBLOCK=12; +01730 (*-41() STACKSZWORD = 2 ; STACKSZADDR = 4 ; STACKSZINT = 2 ; ()-41*) +01735 (*+41() STACKSZWORD =-2 ; STACKSZADDR =-4 ; STACKSZINT =-2 ; ()+41*) +01740 ()+19*) ()+12*) +01741 (*+13() +01742 SZWORD=4; SZADDR=4; SZINT=4; SZREAL=8; SZLONG=4; SZNAK=8; SZPDS=12; SZPROC=8; SZTERMSET=16; +01743 CHARPERWORD=4; SZIDBLOCK=12; +01744 (*-41() STACKSZWORD = 4 ; STACKSZADDR = 4 ; STACKSZINT = 4 ; ()-41*) +01745 (*+41() STACKSZWORD = -4 ; STACKSZADDR = -4 ; STACKSZINT = -4 ; ()+41*) +01746 ()+13*) +01750 ()+02*) +01800 (*+03() +01850 SZWORD=1; SZADDR=1; SZINT=1; SZREAL=3; SZNAK=3; SZPDS=3; (*??*) (*SZLONG??*) SZPROC=1; SZTERMSET=1; +01900 CHARPERWORD=2 ; +01950 (*-41() STACKSZWORD = 1 ; STACKSZADDR = 1 ; STACKSZINT = 1 ; ()-41*) +02000 ()+03*) +02050 (*+04() +02100 SZWORD=2; SZADDR=4; SZINT=4; SZREAL=4; SZLONG=4; SZNAK=6; (*SZPDS??*) SZPROC=4; SZTERMSET=1; +02150 CHARPERWORD=2 ; +02200 (*-41() STACKSZWORD = 2 ; STACKSZADDR = 4 ; STACKSZINT = 4 ; ()-41*) +02250 ()+04*) +02300 (*+05() +02350 SZWORD=2; SZADDR=2; SZINT=2; SZREAL=4; SZLONG=4; SZNAK=4; SZPDS=6; SZPROC=4; SZTERMSET=16; +02400 CHARPERWORD=4 ; SZIDBLOCK=5 ; +02450 (*-41() STACKSZWORD = 2 ; STACKSZADDR = 2 ; STACKSZINT = 2 ; ()-41*) +02500 (*+41() STACKSZWORD = -2 ; STACKSZADDR = -2 ; STACKSZINT = -2 ; ()+41*) +02550 ()+05*) +02600 (*+11() CHARSPACE = 64 ; ()+11*) +02700 (**) +02750 (***************************************) +02800 (* INCREASING AND DECREASING PCOUNTS *) +02850 (***************************************) +02900 (**) +02950 (*+11() +03000 INCRF=00004000000000000000B; (*INCREMENT FOR PCOUNTS WHEN USING FIRSTWORD*) +03050 INCRF2=00010000000000000000B; +03100 ONEF=00004000000000000000B; (*FOR TESTING PCOUNTS*) +03150 TWOF=00010000000000000000B; +03200 ()+11*) +03250 (*+12() (*+03() +03300 INCRF=32; (*INCREMENT FOR PCOUNTS WHEN USING FIRSTWORD*) +03350 INCRF2=64; +03400 ONEF=32; (*FOR TESTING PCOUNTS*) +03450 TWOF=64; +03500 ()+03*) +03510 (*+02() +03520 INCRF=1; +03525 INCRF2=2; +03530 ONEF=1; +03535 TWOF=2; +03540 ()+02*)()+12*) +03550 (*+13() (*+05() +03600 INCRF = 65536 ; (* INCREMENT FOR PCOUNTS WHEN USING FIRST WORD *) +03650 INCRF2 = 131072 ; +03700 ONEF = 65536 ; (* FOR TESTING PCOUNTS *) +03750 TWOF = 131072 ; +03760 ()+05*) +03765 (*+02() +03766 INCRF = 1; +03767 INCRF2 = 2; +03768 ONEF = 1; +03769 TWOF = 2; +03770 ()+02*) +03800 ()+13*) +03850 (**) +03855 (*************************************) +03900 (* SIZE OF OBJECTS * VARIABLE SIZE * *) +03950 (*************************************) +04000 (**) +04050 (*+11() +04100 STRUCTCONST=1; +04150 ELSCONST=2; +04200 STRINGCONST=1; +04250 NEXTOFFSET=2; (*OFFSET OF NEXT WITHIN OBJECT*) +04300 MULTCONST=4; +04310 REFRCONST=MULTCONST; +04320 RECRCONST=MULTCONST; +04350 REFSLNCONST=MULTCONST; +04400 SORTSHIFT=4398046511104; +04450 ()+11*) +04500 (*+12() (*+03() +04550 STRUCTCONST=3; +04600 ELSCONST=4; +04650 STRINGCONST=4; +04700 NEXTOFFSET=7; (*OFFSET OF NEXT WITHIN OBJECT*) +04750 MULTCONST=11; +04800 REFSLNCONST=11; +04805 ()+03*) +04807 (*+02() +04810 STRUCTCONST=10; +04815 ELSCONST=20; +04820 STRINGCONST=6; +04825 NEXTOFFSET=20; (*OFFSET OF NEXT WITHIN OBJECT*) +04830 MULTCONST=38; +04831 REFRCONST=MULTCONST; +04832 RECRCONST=MULTCONST; +04835 REFSLNCONST=MULTCONST; +04840 (* SORTSHIFT IS NOT USET IN THE EM MACHINE AS THERE IS NO DEFINITION OF THE UNDERLYING HARDWARE *) +04845 ()+02*) +04850 ()+12*) +04900 (*+13() +04901 (*+05() +04950 STRUCTCONST = 6 ; +05000 ELSCONST = 10; +05050 STRINGCONST = 10; +05100 NEXTOFFSET = 12 ; (* OFFSET OF NEXT WITHIN OBJECT *) +05150 MULTCONST = 18 ; +05160 REFSLNCONST = MULTCONST ; +05170 REFRCONST = MULTCONST ; +05180 RECRCONST = MULTCONST ; +05210 SORTSHIFT = 1; +05211 ()+05*) +05212 (*-05() +05213 STRUCTCONST = 12; +05214 ELSCONST = 20; +05215 STRINGCONST = 20; +05216 NEXTOFFSET = 24; +05217 MULTCONST = 36; +05218 REFSLNCONST = MULTCONST; +05219 REFRCONST = MULTCONST; +05220 RECRCONST = MULTCONST; +05221 (*-02() SORTSHIFT = 1; ()-02*) +05222 ()-05*) +05250 ()+13*) +05300 (**) +05350 (*************************************) +05400 (* * FIXED SIZE * *) +05450 (*************************************) +05500 (**) +05550 (*+11() +05600 ROUTINESIZE=2; +05650 PROUTINESIZE=2; +05700 REF1SIZE=3; +05750 REF2SIZE=4; +05800 CREFSIZE=2; +05850 REFNSIZE=2; +05950 REFSL1SIZE=2; +06100 RECNSIZE=3; +06150 UNSSIZE=2; +06200 UNPSIZE=1; +06250 AFILESIZE=8; +06300 COVERSIZE=15; +06350 ()+11*) +06400 (*+12() (*+03() +06450 ROUTINESIZE=4; +06500 PROUTINESIZE=3; +06550 REF1SIZE=3; +06600 REF2SIZE=5; +06650 CREFSIZE=4; +06700 REFNSIZE=3; +06800 REFSL1SIZE=6; +06950 RECNSIZE=8; +07000 UNSSIZE=4; +07050 UNPSIZE=4; +07100 AFILESIZE=24; +07150 COVERSIZE=20; +07155 ()+03*) +07157 (*+02() (*SIZE OF FIELDS OF OBJECT IN BYTES*) +07160 ROUTINESIZE=14; +07162 PROUTINESIZE=14; +07164 REF1SIZE=18; +07166 REF2SIZE=24; +07168 CREFSIZE=18; +07170 REFNSIZE=16; +07174 REFSL1SIZE=16; +07178 RECNSIZE=24; +07180 AFILESIZE=46; +07182 COVERSIZE=88; +07198 ()+02*) +07200 ()+12*) +07250 (*+13() +07251 (*-05() +07252 ROUTINESIZE = 12; +07253 PROUTINESIZE = 16; +07254 REF1SIZE = 20; +07255 REF2SIZE = 24; +07256 CREFSIZE = 16; +07257 REFNSIZE = 16; +07258 REFSL1SIZE = 20; +07259 RECNSIZE = 28; +07260 UNSSIZE = 12; +07261 UNPSIZE = 12; +07262 AFILESIZE = 64; +07263 COVERSIZE = 104; +07264 ()-05*) +07265 (*+05() +07300 ROUTINESIZE = 6 ; +07350 PROUTINESIZE = 8; +07400 REF1SIZE = 10; +07450 REF2SIZE = 12; +07500 CREFSIZE = 8 ; +07550 REFNSIZE = 8 ; +07650 REFSL1SIZE=10; +07800 RECNSIZE = 14 ; +07850 UNSSIZE = 6 ; +07900 UNPSIZE = 6 ; +07950 AFILESIZE = 32 ; +08000 COVERSIZE = 52 ; +08001 ()+05*) +08050 ()+13*) +08100 (**) +08150 (*+11() +08200 LFMOFFSET=0; (*OFFSETS WITHIN AFILE*) +08250 PFMOFFSET=1; +08300 PMOFFSET=2; +08350 LMOFFSET=3; +08400 TERMOFFSET=5; +08450 ()+11*) +08500 (*+12() (*+03() +08550 LFMOFFSET=2; (*OFFSETS WITHIN AFILE*) +08600 PFMOFFSET=3; +08650 PMOFFSET=4; +08700 LMOFFSET=5; +08750 TERMOFFSET=7; +08755 ()+03*) +08757 (*+02() +08760 LFMOFFSET=0; (*OFFSETS WITHIN AFILE*) +08765 PFMOFFSET=4; +08770 PMOFFSET=8; +08775 LMOFFSET=12; +08780 TERMOFFSET=20; +08800 ()+02*) ()+12*) +08850 (*+13() +08851 (*-05() +08852 LFMOFFSET = 0; +08853 PFMOFFSET = 4; +08854 PMOFFSET = 8; +08855 LMOFFSET = 12; +08856 TERMOFFSET = 20; +08857 ()-05*) +08858 (*+05() +08900 LFMOFFSET = 0 ; (* OFFSETS WITHIN A FILE *) +08950 PFMOFFSET = 2 ; +09000 PMOFFSET = 4 ; +09050 LMOFFSET = 6 ; +09100 TERMOFFSET = 10 ; +09101 ()+05*) +09150 ()+13*) +09155 (*+01() BUFFOFFSET=32; ()+01*) (*OFFSET OF THE ACTUAL BUFFER WITHIN A FETROOM *) +09160 (*+02() BUFFOFFSET=18; ()+02*) +09200 (**) +09250 (*************************) +09300 (* ENVIRONMENT ENQUIRIES *) +09350 (*************************) +09400 (**) +09450 ERRORCHAR='*'; +09500 (*-50() MAXABSCHAR=127; ()-50*) +09550 (*+50() MAXABSCHAR=63; ()+50*) +09600 (*+11() +09650 BITSWIDTH=60; +09700 BYTESWIDTH=10; +09750 MINBOUND=-4194303; +09800 MAXBOUND=+4194303; +09810 HIOFFSET=377377B; +09850 INTWIDTH=16; +09900 REALWIDTH=16; +09950 EXPWIDTH=3; +10000 INTSPACE=17; (*INTWIDTH+1*) +10050 REALSPACE=23; (*REALWIDTH+EXPWIDTH+4*) +10100 COMPLSPACE=48; (*2*REALWIDTH+2*EXPWIDTH+10*) +10150 MAXINT=7777777777777777B; +10200 FAKEPI=17206220773250420551B; +10250 ()+11*) +10300 (*+12() +10350 BITSWIDTH=16; +10400 BYTESWIDTH=2; +10450 MINBOUND=-32767; +10500 MAXBOUND=+32767; +10550 INTWIDTH=5; +10600 REALWIDTH=16; (*NEEDS ATTENTION*) +10650 EXPWIDTH=3; +10700 INTSPACE=6; (*INTWIDTH+1*) +10750 REALSPACE=23; (*REALWIDTH+EXPWIDTH+4*) +10800 COMPLSPACE=48; (*2*REALWIDTH+2*EXPWIDTH+10*) +10850 MAXINT = 32767; +10860 HIOFFSET=32511; +10900 ()+12*) +10950 (*+13() +11000 BITSWIDTH = 32 ; +11050 BYTESWIDTH = 4 ; +11100 MINBOUND = -2147483647 ; +11150 MAXBOUND = +2147483647 ; +11200 INTWIDTH = 10 ; +11250 REALWIDTH = 16 ; +11300 EXPWIDTH = 3 ; +11350 INTSPACE = 11 ; +11400 REALSPACE = 23 ; +11450 COMPLSPACE = 48 ; +11500 MAXINT = 2147483647; +11505 HIOFFSET=2147483391; +11510 (*+05() FAKEPI = 1073291771 ; FAKEPI1 = 1413754136 ; ()+05*) +11550 ()+13*) +11600 (*+01() +11650 INTUNDEF=60000000000200400000B; +11700 MINREALEXP = -294 ; +11750 MAXREALEXP = 324 ; +11800 TRUEVAL = -1; +11850 ()+01*) +11860 (*+02() MINREALEXP = -10000 ; MAXREALEXP = 10000; TRUEVAL=1; LONGUNDEF=0.0;()+02*) +11865 (* INTUNDEF IS A VARIABLE IN THE 02 MACHINE (-32768) *) +11900 (*+03() INTUNDEF=100000B; ()+03*) +11950 (*+05() +12000 INTUNDEF= - 2147483647 - 1 ; +12050 LONGUNDEF = 0.0 ; +12100 MINREALEXP = -10000 ; +12150 MAXREALEXP = 10000 ; +12200 TRUEVAL=1; +12250 ()+05*) +12300 (**) +12350 (**************************************) +12400 (* ERROR NUMBERS (PROBABLY TEMPORARY) *) +12450 (**************************************) +12500 (**) +12550 RASSIG=1; +12600 RSEL=2; +12650 RDEREF=3; +12700 RASSIGNIL=4; +12750 RSELNIL=5; +12800 RDEREFNIL=6; +12850 IDREL=7; +12900 RPOWNEG=8; +12950 RBYTESPACK=9; +13000 RCLOWER=13; RCUPPER=14; RLWUPB=15; +13050 RSL1ERROR=16; RSL2ERROR=17; RSLICE=18; RSLICENIL=19; +13100 RMULASS=20; RROUTIN=21; +13150 RCHARERROR=22; +13200 RSCOPE=23; (*THE COMPASS FOR TASSTPT KNOWS THIS*) +13250 RARG=24; +13300 RDUMMY=25; +13350 BADIDF=32; +13400 NOWRITE=33; NOESTAB=34; POSMIN=35; POSMAX=36; +13450 NOTOPEN=38; NOREAD=39; NOSET=40; +13500 NORESET=41; NOSHIFT=43; NOBIN=44; +13550 NOALTER=45; NOMOOD=46; WRONGMULT=47; +13600 NODIGIT=49;NOLOGICAL=50; +13650 NOPHYSICAL=51; WRONGCHAR=52; WRONGVAL=53; SMALLLINE=56; +13700 (**) +13750 (*******************) +13800 (* VARIOUS OFFSETS *) +13850 (*******************) +13900 (**) +13950 (*+01() +14000 FIRSTIBOFFSET=531B; (*OFFSET OF GLOBAL VARIABLE FIRSTIB*) +14050 INPUTEFET=264B; (*OFFSET OF FETROOM FOR INPUT*) +14100 OUTPUTEFET=23B; (*OFFSET OF FETROOM FOR OUTPUT*) +14150 ()+01*) +14200 (*+03() +14250 (*THESE NEED ATTENTION ------------------------------------------------*) +14300 FIRSTIBOFFSET=531B; (*OFFSET OF GLOBAL VARIABLE FIRSTIB*) +14350 INPUTEFET=264B; (*OFFSET OF FETROOM FOR INPUT*) +14400 OUTPUTEFET=23B; (*OFFSET OF FETROOM FOR OUTPUT*) +14450 ()+03*) +14500 (*+05() +14550 (* THESE NEED ATTENTION ----------------------------------------------*) +14600 FIRSTIBOFFSET = 0 ; (* OFFSET OF GLOBAL VARIABLE FIRSTIB *) +14750 ()+05*) +14800 (*-05() (*-02() MAXSIZE=110B; (*MAXIMUM SIZE OF NONSTOWED OBJECT - MUST BE < 1ST PROGRAM ADDRESS*) ()-02*) ()-05*) +14810 (*+02() MAXSIZE = 16; (* MAXIMUM SIZE OF NONSTOWED OBJECT - MUST BE < FIRST DATA ADDRESS *) ()+02*) +14850 (*+05() MAXSIZE = 8 ; (* MAXIMUM SIZE OF NONSTOWED OBJECT - MUST BE < FIRST DATA ADDRESS *) ()+05*) +14900 (*+11() +14950 RECOFFSET=0; (*OFFSET OF RECGEN WITHIN RANGEBLOCK*) +15000 (*-41() +15050 IBCONST = 10; +15100 RGCONST = 4 ; +15150 ()-41*) +15200 ()+11*) +15250 (*+12() (*-02() +15300 RECOFFSET=2; (*OFFSET OF RECGEN WITHIN RANGEBLOCK*) +15350 (*-41() +15400 IBCONST = 18; +15450 RGCONST = 6 ; +15500 ()-41*) ()-02*) +15505 (*+02() (*+19() +15510 RECOFFSET=6; (*OFFSET OF RECGEN WITHIN A RANGEBLOCK*) +15515 (*+41() +15520 IBCONST = -12; +15525 RGCONST = -20; +15527 ()+41*) +15529 (*-41() (*EDUCATED GUESSES*) +15530 IBCONST = 12; +15533 RGCONST = 20; +15535 ()-41*) ()+19*) +15537 (*-19() (*LESS EDUCATED GUESSES*) +15539 RECOFFSET=4; +15541 (*+41() +15542 IBCONST = -8; +15543 RGCONST = -12; +15544 ()+41*) +15546 (*-41() +15547 IBCONST = 8; +15548 RGCONST = 12; +15549 ()-41*) ()-19*) +15550 ()+02*) +15560 ()+12*) +15600 (*+13() +15700 (*-41() +15750 IBCONST = 20 ; +15800 RGCONST = 24 ; +15850 ()-41*) +15900 (*+41() +15901 (*+05() +15650 RECOFFSET = 4 ; (* OFFSET OF RECGEN WITHIN RANGEBLOCK *) +15950 IBCONST = -12 ; +16000 RGCONST = -12 ; +16001 ()+05*) +16002 (*-05() +16003 RECOFFSET = 8; +16005 IBCONST=-20; +16006 RGCONST=-24; +16007 ()-05*) +16050 ()+41*) +16100 ()+13*) +16150 (*+01() PARAMOFFSET = 0 ; DLOFFSET = +1 ; ()+01*) +16160 (*+02() PARAMOFFSET = (*+12() -14 ()+12*) (*+13() -16 ()+13*); +16170 DLOFFSET = (*+12() (*+19() -8 ()+19*) (*-19() -4 ()-19*) ()+12*) (*+13() -8 ()+13*) ; ()+02*) +16200 (*+05() PARAMOFFSET = -12 ; DLOFFSET = -6 ; ()+05*) +16250 (**) +16300 (**********************) +16350 (* TRANSPUT CONSTANTS *) +16400 (**********************) +16450 (*+01() +16500 FORREAD = 123B ; FORWRITE = 123B ; ONLINE = 10B ; +16550 ()+01*) +16560 (*+02() +16570 FORREAD = 1 ; FORWRITE = 2 ; ONLINE = 0 ; +16580 DATAINBUF = 4 ; EOLINTEXTFIL = 8 ; EXTERNFIL = 32 ; STATICNAME = 64 ; +16590 ()+02*) +16600 (*+05() +16650 FORREAD = 1 ; FORWRITE = 2 ; ONLINE = 0 ; +16700 DATAINBUF = 4 ; EOLINTEXTFIL = 8 ; EXTERNFIL = 32 ; STATICNAME = 64 ; +16750 ()+05*) +16800 (**) +16850 TYPE (* TYPE TYPE TYPE TYPE TYPE TYPE TYPE TYPE *) +16900 (**) +16950 SEVERAL = 0..10; +17000 (*-01() ALFA = PACKED ARRAY [ 1..10 ] OF CHAR ; ()-01*) +17050 (**) +17100 ACCURATEPI = RECORD +17150 CASE SEVERAL OF +17160 (*-01() (*-05() 0: (); ()-05*) ()-01*) +17200 (*+01() 0: (FAKEPI:INTEGER); ()+01*) +17210 (*+05() 0: ( FAKEPI, FAKEPI1: INTEGER ) ; ()+05*) +17250 1: (ACTUALPI:REAL); +17260 2,3,4,5,6,7,8,9,10: (); +17300 END; +17350 (**) +17400 (******************) +17450 (* ALGOL 68 MODES *) +17500 (******************) +17550 (*+01() A68INT=INTEGER; A68LONG = RECORD V1: INTEGER; V2: INTEGER END; ()+01*) +17600 (*+02() +17650 (*+12() A68INT=INTEGER; A68LONG=REAL; ()+12*) +17655 (*+13() A68INT=INTEGER; A68LONG=REAL; ()+13*) +17700 ()+02*) +17750 (*+03() A68INT=INTEGER; A68LONG=REAL; ()+03*) +17800 (*+04() A68INT=LONG; A68LONG=LONG; ()+04*) +17850 (*+05() A68INT = INTEGER ; A68LONG = REAL ; ()+05*) +17900 (**) +17950 (*+01() ASPROC = INTEGER; (*SCALAR TYPE TO ENCOMPASS A PASCAL PROCEDURE PARAMETER*) ()+01*) +18000 (*+02() (*+12() (*-19() ASPROC = LONG; ()-19*) +18005 (*+19() ASPROC = REAL; ()+19*) ()+12*) +18010 (*+13() ASPROC = REAL; ()+13*) ()+02*) +18050 (*+03() ASPROC = INTEGER; ()+03*) +18100 (*+04() ASPROC = INTEGER; ()+04*) +18150 (*+05() ASPROC = REAL ; ()+05*) +18200 (**) +18250 (**************************************) +18300 (* SIZE OF FIELDS IN OBJECTS *) +18350 (**************************************) +18400 (**) +18450 (*+11() +18500 PCOUNTRANGE=0..8191; +18550 CCOUNTRANGE=0..4095; +18600 OFFSETRANGE=-4095..4095; +18650 SIZERANGE=0..4095; +18700 DEPTHRANGE=0..4095; +18750 ELSRANGE=0..377777B; +18800 OFFSETPCOUNT=0..33554431; +18850 CHAN=0..377777B; +18900 BYTE=0..63; +18950 ()+11*) +19000 (*+12() (*+03() +19050 PCOUNTRANGE=0..2047; +19100 CCOUNTRANGE=0..511; +19150 OFFSETRANGE=-255..255; +19200 SIZERANGE=0..511; +19250 DEPTHRANGE=0..127; +19300 ELSRANGE=INTEGER; +19350 OFFSETPCOUNT=INTEGER; +19400 CHAN=ASPROC; (*MUST BE A GOOD IMITATION OF A PROCEDURE*) +19440 BYTE=0..255; +19450 ()+03*) +19460 (*+02() +19465 PCOUNTRANGE=0..2047; +19467 CCOUNTRANGE=0..511; +19469 OFFSETRANGE=INTEGER; +19471 SIZERANGE=0..511; +19475 DEPTHRANGE=0..255; +19477 ELSRANGE=INTEGER; +19479 OFFSETPCOUNT=INTEGER; +19481 CHAN=ASPROC; (*MUST BE A GOOD IMITATION OF A PROCEDURE*) +19483 BYTE=0..255; +19499 ()+02*) +19500 ()+12*) +19550 (*+13() +19600 PCOUNTRANGE = 0..32767 ; +19650 CCOUNTRANGE = 0..32767 ; +19700 OFFSETRANGE =-127..127; +19750 SIZERANGE = 0..255; +19800 DEPTHRANGE = 0..255 ; +19850 ELSRANGE = INTEGER ; +19900 OFFSETPCOUNT = INTEGER ; +19950 CHAN = ASPROC ; (* MUST BE A GOOD IMITATION OF A PROCEDURE *) +20000 BYTE = 0..255 ; +20050 ()+13*) +20100 BOUNDSRANGE=MINBOUND..MAXBOUND; +20150 VECCHARS = PACKED ARRAY [1..1000] OF CHAR ; +20200 (**) +20250 (**********************) +20300 (* POINTERS *) +20350 (**********************) +20400 (**) +20445 (*FOR MANIPULATING INVOCATION BLOCK POINTERS*) +20450 IPOINT = (*+12() (*-19()INTEGER()-19*) (*+19()LONG()+19*) ()+12*) (*+13() INTEGER ()+13*) ; +20500 PROCPOINT = ^PROCBLOCK; +20550 DPOINT = ^DEEBLOCK; +20600 UNDRESSP = ^UNDRESS; +20650 OBJECTP = ^OBJECT; +20700 OBJECTPP = ^OBJECTP; +20750 INTPOINT = ^INTEGER; +20800 CHARPOINT = ^CHAR; +20850 (**) +20900 (**********************) +20950 (* TRANSPUT *) +21000 (**********************) +21050 (**) +21100 (*+05() +21150 CFILE = PACKED RECORD +21200 PTR : ^ CHAR ; +21250 CNT : INTEGER ; +21300 BASE : ^ CHAR ; +21350 FLAG : 0..32767 ; +21400 FILEDES : BYTE +21450 END ; +21460 PCFILE = ^CFILE; +21500 ()+05*) +21550 (**) +21600 STATUSFIELD=(OPENED, LINEOVERFLOW, PAGEOVERFLOW, PFE, LFE, NOTINITIALIZED, NOTRESET, +21650 READMOOD, WRITEMOOD, CHARMOOD, BINMOOD, LAZY, NOTSET, CARRIAGE, STARTUP); +21700 POSSFIELD=(RESETPOSS, SETPOSS, GETPOSS, PUTPOSS, BINPOSS, ESTABPOSS, ASSPOSS); +21750 FETROOM = PACKED RECORD (*THE OBJECT CREATED BY THE PASCAL SYSTEM FOR A PASCAL FILE*) +21800 (*+01() +21850 LINECOUNTER: INTEGER; +21900 CHARBUFFER: ARRAY [1..10] OF INTEGER; +21950 SENTINEL: INTEGER; +22000 BUFELPTR: INTEGER; +22050 EOFB: 0..3B; DISP: 0..177B; RMSTUFF: 0..77777777777B; LRL: 0..777777B; +22100 (*-52() +22150 LFN: PACKED ARRAY [1..7] OF CHAR; STATUS: 0..777B; +22200 DT: PACKED ARRAY [1..2] OF CHAR; FILL1: 0..17777777777B; FIRST: ^INTEGER; +22250 FILL2: 0..177777777777777B; INN: ^INTEGER; +22300 FILL3: 0..177777777777777B; OUT: ^INTEGER; +22350 FILL4: 0..177777777777777B; LIMIT: ^INTEGER; +22400 RESTOFFET: ARRAY [1..13] OF INTEGER; +22450 ()-52*) +22500 (*+52() +22550 FILL1: 0..37B; BUFLGT: 0..1777777B; BUFADR: 0..777777B; BUFEND: 0..777777B; +22600 OUT: INTEGER; +22650 LFN: PACKED ARRAY [1..7] OF CHAR; STATUS: 0..777B; +22700 RESTOFFIT: ARRAY [1..15] OF INTEGER; +22750 ()+52*) +22800 BUFFER: ARRAY [0..128] OF INTEGER; +22850 ()+01*) +22855 (*+02() +22860 PTR: ^CHAR; (* THE POINTER F^ ,POINTS INTO BUFADR *) +22862 FLAGS: INTEGER; (* VARIOUS FLAGS USED BY PC RUNTIME SYSTEM *) +22864 FNAME: ^CHAR; (* THE FILE NAME, SHOULD REALLY BE STRING *) +22866 UFD: INTEGER; (* UNIX FILE DESCRIPTOR *) +22868 SIZE: INTEGER; (* THE ELEMENT SIZE *) +22870 COUNT: INTEGER; (* NUMBER OF BYTES LEFT IN BUFFER *) +22872 BUFLEN: INTEGER;(* EFFECTIVE LENGTH OF BUFFER *) +22874 BUFADR: PACKED ARRAY [1..512] OF CHAR; (* THE I/O BUFFER *) +22876 (* THE LAST LINE PRESUMES ONLY FILE OF CHAR ALLOWED IN ALGOL68S *) +22878 (* THUS SIZE WILL ALWAYS BE 1, THESE NEED CHANGING IF THIS IS NOT TRUE *) +22880 ()+02*) +22900 (*+03() +22950 FILENUMBER: INTEGER; +23000 EOFFLAG: INTEGER; +23050 BUFFERSIZE: INTEGER; +23100 BLOCKNUMBER: INTEGER; +23150 BLOCKSLEFT: INTEGER; +23200 FILESTATUS: INTEGER; +23250 EOLFLAG: INTEGER; +23300 CURRBYTE: INTEGER; +23350 CURRLIMIT: INTEGER; +23400 PASBUFVAR: INTEGER; +23450 BUFFER: ARRAY [0..255] OF INTEGER; +23500 ()+03*) +23550 (*+05() +23600 XOBJ: CHARPOINT ; +23650 XFILE: PCFILE ; +23700 XFLAG: INTEGER ; +23750 XOBJSIZE: INTEGER ; +23800 XBUF: CHAR ; +23850 ()+05*) +23900 END ; +23950 FETROOMP=^FETROOM; +24000 STATUSSET=SET OF STATUSFIELD; +24050 POSSSET=SET OF POSSFIELD; +24100 (*+01() LFNTYPE = ALFA ; ()+01*) +24150 (*-01() LFNTYPE = OBJECTP ; (* ACTUALLY A STRING *) ()-01*) +24200 (*-01() TERMSET=SET OF CHAR; ()-01*) +24250 (*+01() TERMSET=SET OF ':'..'<'; ()+01*) +24300 (*-01() FYL = TEXT; ()-01*) +24350 (*+01() FYL = SEGMENTED FILE OF CHAR; ()+01*) +24400 INTSTR = PACKED ARRAY [1..INTSPACE] OF CHAR; +24450 REASTR = PACKED ARRAY [1..REALSPACE] OF CHAR; +24500 CMPXSTR= PACKED ARRAY [1..COMPLSPACE] OF CHAR; +24550 GETBUFTYPE=PACKED ARRAY [0..199] OF CHAR; (*FOR INPUTTING STRINGS - SEE GETT*) +24600 MINT = (*+01()INTEGER()+01*) (*+02()REAL()+02*) (*+05()REAL()+05*) ; +24650 (*A MODE WHOSE VALUES ARE THE NON-NEGATIVE INTEGERS UP TO 10*POWOF2. +24700 THE OPERATIONS OF ADDITION, SUBTRACTION, AND MULTIPLICATION BY +24750 10 AND BY INTEGRAL POWERS OF 2 ARE ASSUMED TO WORK*) +24800 (**) +24850 (**********************) +24900 (* SORTS *) +24950 (**********************) +25000 (**) +25050 STRUCTYPE=( +25100 STRING, (*MUST BE FIRST BECAUSE THE COMPILER KNOWS ABOUT IT*) +25150 ROUTINE, (*THE COMPASS CODE FOR CALL KNOWS ABOUT THIS*) +25200 REFSLN, (*THE COMPASS CODE FOR TRIMS KNOWS ABOUT THIS*) +25250 REFN, (*THE COMPASS FOR NASSTPT KNOWS ABOUT THIS *) +25300 RECN, +25400 REF1, +25450 REF2, +25500 CREF, +25550 STRUCT, +25600 IELS, +25650 MULT, +25700 REFSL1, +25750 REFR, +25800 RECR, +25850 UNDEF, +25900 NILL, +25950 PASCROUT, +26000 AFILE, +26050 COVER); +26100 (**) +26150 (*********************************) +26200 (* THE THING *) +26250 (*********************************) +26300 (**) +26350 PDS = PACKED RECORD +26400 UI, LI: BOUNDSRANGE; +26450 (*+01() FILL: 0..3B; ()+01*) +26500 DI: SIZERANGE +26550 END; +26600 (**) +26650 UNDRESS = RECORD +26700 CASE SEVERAL OF +26750 0: (FIRSTPTR: OBJECTP; FILL0: INTEGER); +26800 1: (FIRSTWORD: INTEGER); +26850 2: (FIRSTINT: A68INT); +26900 3: (FIRSTLONG: A68LONG); +26950 4: (FIRSTREAL: REAL); +27000 5: (FIRSTTERMSET: TERMSET) ; +27050 6 , 7 , 8 , 9 , 10 : () ; +27100 END; +27150 (**) +27200 (*+11() +27250 OBJECT = PACKED RECORD +27300 CASE SEVERAL OF +27350 0: (FIRSTPTR: OBJECTP; FILL0: INTEGER); +27400 1: (FIRSTWORD: INTEGER; +27410 SECONDWORD: INTEGER); +27450 2: (PCOUNT: PCOUNTRANGE; +27500 CASE SORT: STRUCTYPE OF +27550 STRUCT: +27650 ( OSCOPE: DEPTHRANGE; +27700 LENGTH: SIZERANGE; +27725 DBLOCK: DPOINT; +27750 RE: REAL; +27800 IM: REAL); +27850 MULT: +27950 (OSCOPEM: DEPTHRANGE; +28000 FILLM1: SIZERANGE; +28025 PVALUE: OBJECTP; +28037 IHEAD: OBJECTP; (*1*) +28040 FILLM5: 0..1; +28050 FILLM2: ELSRANGE; +28150 FILLM3:OBJECTP; +28200 FILLM4: OBJECTP; (*2*) +28250 BPTR: OBJECTP; +28300 FPTR: OBJECTP; (*AT BOTTOM OF WORD TO MATCH RECEGN*) +28350 LBADJ: BOUNDSRANGE; (*3*) (*(DIST FROM EL[0,...,0] TO 1ST REAL EL) - ELSCONST*) +28400 MDBLOCK: DPOINT; +28450 SIZE: DEPTHRANGE; +28500 ROWS: 0..7; +28550 DESCVEC: ARRAY [0..7] OF PDS); (*4*) +28600 IELS: +28700 (OSCOPEE: DEPTHRANGE; +28750 CCOUNT: CCOUNTRANGE; +28775 DBLOCKE: DPOINT; +28850 IHEADE: OBJECTP; (*1*) +28860 FILLE2: 0..1; +28900 D0: ELSRANGE; +28925 FILLE1: OBJECTP (*BOTTOM OF 1*) ); +28950 ROUTINE: +29050 (OSCOPER: DEPTHRANGE; +29100 FILLR: SIZERANGE; +29125 PROCBL: PROCPOINT; +29150 ENVCHAIN: IPOINT; (*1*) +29200 FILLR1: INTEGER (*2*) ); +29250 PASCROUT: +29350 ( OSCOPEP: DEPTHRANGE; +29400 PPARAMS: SIZERANGE ; +29405 FILLPR: OBJECTP ; +29410 PPROCBL: ASPROC (*1*) ); +29450 REF1: +29550 ( OSCOPERF1: DEPTHRANGE; +29600 FILLRF11: SIZERANGE; +29605 PVALUEF1: DPOINT; +29610 FILLRF12: OBJECTP; (*1*) +29615 FILLRF13: 0..1; +29620 OFFSETRF1: ELSRANGE; +29630 ANCESTORF1: OBJECTP; +29650 VALUE: A68INT (*2*) ); +29700 REF2: +29800 ( OSCOPERF2: DEPTHRANGE; +29850 FILLRF21: SIZERANGE; +29855 PVALUEF2: DPOINT; +29860 FILLRF22: OBJECTP; (*1*) +29865 FILLRF23: 0..1; +29870 OFFSETRF2: ELSRANGE; +29880 ANCESTORF2: OBJECTP; +29900 LONGVALUE: A68LONG ); (*2*) +29950 REFN: +30050 (OSCOPEFN: DEPTHRANGE; +30100 FILLFN: SIZERANGE; +30125 PVALUEFN: OBJECTP; +30130 FILLFN1:OBJECTP; (*1*) +30132 FILLFN2: 0..1; +30135 OFFSETFN:ELSRANGE; +30140 ANCESTORFN:OBJECTP); +30150 CREF: +30250 (OSCOPECF: DEPTHRANGE; +30300 FILLCREF: SIZERANGE ; +30325 PVALUECF : DPOINT ; +30330 IPTR :UNDRESSP; (*1*) +30332 FILLCF1: 0..1; +30335 OFFSETCF:ELSRANGE; +30350 ANCESTORCF: OBJECTP ) ; +30400 REFR: +30500 ( OSCOPERR: DEPTHRANGE; +30550 CCOUNTR: CCOUNTRANGE; +30575 PVALUERR: OBJECTP; +30650 FILLRR0: OBJECTP; (*1*) +30660 FILLRR4: 0..1; +30700 FILLRR1: ELSRANGE; +30705 ANCESTOR: OBJECTP; +30710 FILLRR2: OBJECTP; (*2*) +30750 FILLRR3: OBJECTP; +30760 LBADJRR: BOUNDSRANGE; (*3*) +30768 MDBLOCKRR: DPOINT; +30776 SIZERR: DEPTHRANGE; +30784 ROWSNRR:0..7; +30792 DESCVECRR:ARRAY [0..7] OF PDS); (*4*) +30800 REFSL1: +30900 (OSCOPEL: DEPTHRANGE; +30950 CCOUNTL: CCOUNTRANGE; +30975 DBLOCKL: DPOINT; +31050 FILLL2: OBJECTP; (*1*) +31060 FILLL1: 0..1; +31100 OFFSET: ELSRANGE; +31125 ANCSTRL: OBJECTP; +31150 FILLL3: INTEGER (*2*) ); +31200 REFSLN: +31300 (OSCOPEN: DEPTHRANGE; +31350 CCOUNTN: CCOUNTRANGE; +31375 FILLN4: OBJECTP; +31450 FILLN: OBJECTP; (*1*) +31460 FILLN5: 0..1; +31500 FILLN0: ELSRANGE; +31525 ANCSTRN: OBJECTP; +31550 FILLN1: OBJECTP; (*2*) +31600 FILLN2: OBJECTP; +31650 FILLN3: OBJECTP; +31700 LBADJN: BOUNDSRANGE; (*3*) +31750 MDBLOCKN: DPOINT; +31800 SIZEN: DEPTHRANGE; +31850 ROWSN: 0..7; +31900 DESCVECN: ARRAY [0..7] OF PDS); (*4*) +32300 RECR: +32400 ( OSCOPECR: DEPTHRANGE; +32450 CCOUNTCR: CCOUNTRANGE; +32475 PVALUECR: OBJECTP; +32550 FILLCR0: OBJECTP; (*1*) +32560 FILLCR3: 0..1; +32600 FILLCR1: ELSRANGE; +32625 ANCSTRCR: OBJECTP; +32650 FILLCR2: OBJECTP; (*2*) +32700 PREV: OBJECTP; +32750 NEXT: OBJECTP; +32800 LBADJCR: BOUNDSRANGE; (*3*) +32810 MDBLOCKCR: DPOINT; +32820 SIZECR: DEPTHRANGE; +32830 ROWSNCR:0..7; +32840 DESCVECCR:ARRAY [0..7] OF PDS); (*4*) +32850 RECN: +32950 ( OSCOPECN: DEPTHRANGE; +33000 FILLCN: SIZERANGE; +33025 PVALUECN :OBJECTP; +33050 FILLCN1: OBJECTP; (*1*) +33070 FILLCN4: 0..1; +33080 OFFSETCN:ELSRANGE; +33090 ANCESTORCN:OBJECTP; +33100 FILLCN2: OBJECTP; (*2*) +33150 PREVCN: OBJECTP; +33200 NEXTCN: OBJECTP; +33250 FILLCN3: INTEGER); (*3*) +33300 STRING: +33400 ( FILLST1: DEPTHRANGE; +33450 STRLENGTH: SIZERANGE; +33475 FILLST: DPOINT; +33500 CHARVEC: VECCHARS (*1*) ); +33550 UNDEF, NILL: +33650 ( OSCOPEUN: DEPTHRANGE; +33700 STRLNGUN: SIZERANGE; +33705 PVALUEUN: OBJECTP; +33710 FILLUN1: OBJECTP; (*1*) +33715 FILLUN2: 0..1; +33725 OFFSETUN: ELSRANGE; +33750 ANCESTORUN: OBJECTP; +33800 FILLUN3: OBJECTP; (*2*) +33850 FILLUN4: OBJECTP; +33860 FILLUN5: OBJECTP; +33870 FILLUN6: BOUNDSRANGE; (*3*) +33880 FILLUN7: DPOINT; +33890 FILLUN8: DEPTHRANGE; +33895 ROWSUN: 0..7; +33900 DESCVECUN: ARRAY [0..7] OF PDS); (*4*) +33950 AFILE: (*ACTUALLY, AFILES WILL BE STORED AS STRUCTS, BUT THESE FIELD SELECTORS SHOULD WORK*) +34050 ( OSCOPEF: DEPTHRANGE; +34100 LENGTHF: SIZERANGE; +34125 DBLOCKF: DPOINT; +34150 FILLF1: 0..77777777777777B; (*1*) +34200 LOGICALFILEMENDED: OBJECTP; +34250 FILLF2: 0..77777777777777B; (*2*) +34300 PHYSICALFILEMENDED: OBJECTP; +34350 FILLF3: 0..77777777777777B; (*3*) +34400 PAGEMENDED: OBJECTP; +34450 FILLF4: 0..77777777777777B; (*4*) +34500 LINEMENDED: OBJECTP; +34550 FILLF5: 0..77777777777777B; (*5*) +34600 PCOVER: OBJECTP; +34650 TERM: TERMSET; (*6*) +34700 TERM1: TERMSET); (*7*) +34750 COVER: +34850 ( OSCOPEV: DEPTHRANGE; +34900 FILLV: SIZERANGE; +34925 CHANNEL: CHAN; +34950 STATUS: STATUSSET; +35000 POSSIBLES: POSSSET; +35050 COFCPOS, LOFCPOS, POFCPOS: INTEGER; +35100 CHARBOUND, LINEBOUND, PAGEBOUND: INTEGER; +35150 DOPUTS,DOGETS,DONEWLINE,DONEWPAGE,DOSET,DORESET: ASPROC; +35200 CASE ASSOC: BOOLEAN OF +35250 FALSE: (FILLC: 0..77777777777777B; +35300 BOOK:FETROOMP); +35350 TRUE: (ASSREF:OBJECTP; +35400 CPOSELS:ELSRANGE; +35450 OFFSETDI:SIZERANGE)); +35500 ); +35550 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ; +35600 END; +35650 ()+11*) +35700 (*+12() +35720 (*+03() +35750 OBJECT = PACKED RECORD +35800 CASE SEVERAL OF +35850 0: (FIRSTPTR: OBJECTP; FILL0: INTEGER); +35900 1: (FIRSTWORD: INTEGER); +35950 2: (PCOUNT: PCOUNTRANGE; +36000 SORT: STRUCTYPE; +36050 CASE STRUCTYPE OF +36100 STRUCT: +36150 (OSCOPE: DEPTHRANGE; +36200 LENGTH: SIZERANGE; +36250 DBLOCK: DPOINT; +36300 RE: REAL; +36350 IM: REAL); +36400 MULT: +36450 (SCOPEM: DEPTHRANGE; +36500 FILLM1: CCOUNTRANGE; +36550 PVALUEM: OBJECTP; +36600 D0: ELSRANGE; +36650 ELS: OBJECTP; +36700 IHEAD: OBJECTP; +36750 BPTR: OBJECTP; +36800 FPTR: OBJECTP; +36850 LBADJ: BOUNDSRANGE; (*(DIST FROM EL[0,...,0] TO 1ST REAL EL) - ELSCONST*) +36900 MDBLOCK: DPOINT; +36950 SIZE: SIZERANGE; +37000 ROWS: 0..7; +37050 DESCVEC: ARRAY [0..7] OF PDS); +37100 IELS: +37150 (OSCOPEE: DEPTHRANGE; +37200 CCOUNT: CCOUNTRANGE; +37250 DBLOCKE: DPOINT; +37300 FILLE2: OBJECTP; +37350 D0E: ELSRANGE; ); +37400 ROUTINE: +37450 (SCOPER: DEPTHRANGE; +37500 FILLR: SIZERANGE; +37550 PROCBL: PROCPOINT; +37600 ENVCHAIN: IPOINT); +37650 PASCROUT: +37700 (SCOPEP: DEPTHRANGE; +37750 PPARAMS: SIZERANGE; +37800 PPROCBL: ASPROC ); +37850 REF1: +37900 (SCOPERF1: DEPTHRANGE; +37950 FILLRF11: SIZERANGE; +37955 PVALUERF1: OBJECTP; +37957 FILLRF12: ELSRANGE; +37960 ANCESTRF1: OBJECTP; +38000 VALUE: A68INT); +38050 REF2: +38100 (SCOPERF2: DEPTHRANGE; +38150 FILLRF21: SIZERANGE; +38160 PVALUERF2: OBJECTP; +38170 FILLRF22: ELSRANGE; +38180 ANCESTRF2: OBJECTP; +38200 LONGVALUE: A68LONG); +38250 REFN: +38300 (SCOPEFN: DEPTHRANGE; +38350 FILLFN: SIZERANGE; +38400 PVALUE: OBJECTP; +38410 OFFSETFN: ELSRANGE; +38420 ANCESTFN: OBJECTP); +38450 CREF: +38500 (SCOPEC: DEPTHRANGE; +38550 FILLCREF: SIZERANGE; +38600 PVALUEC : OBJECTP ; +38605 FILLC2: ELSRANGE; +38610 ANCESTCREF: OBJECTP ; +38650 IPTR: UNDRESSP); +38700 REFR: +38750 (SCOPERR: DEPTHRANGE; +38800 CCOUNTR: CCOUNTRANGE; +38850 PVALUER: OBJECTP; +38900 FILLRR1: ELSRANGE; +38950 ANCESTOR: OBJECTP; +39000 FILLRR2: OBJECTP; +39005 FILLRR3: OBJECTP; +39010 FILLRR4: OBJECTP; +39015 LBADJR: BOUNDSRANGE; +39020 MDBLOCKR: DPOINT; +39025 SIZER: SIZERANGE; +39030 ROWSR: 0..7; +39035 DESCVECR: ARRAY [0..7] OF PDS); +39050 REFSL1: +39100 (SCOPEL: DEPTHRANGE; +39150 CCOUNTL: CCOUNTRANGE; +39200 DBLOCKL: DPOINT; +39250 OFFSET: ELSRANGE; +39300 ANCSTRL: OBJECTP); +39400 REFSLN: +39450 (SCOPEN: DEPTHRANGE; +39500 CCOUNTN: CCOUNTRANGE; +39550 FILLN0: OBJECTP; +39600 FILLN1: ELSRANGE; +39650 ANCSTRN: OBJECTP; +39700 FILLN15: OBJECTP; +39750 FILLN2: OBJECTP; +39800 FILLN3: OBJECTP; +39850 LBADJN: BOUNDSRANGE; +39900 MDBLOCKN: DPOINT; +39950 SIZEN: SIZERANGE; +40000 ROWSN: 0..7; +40050 DESCVECN: ARRAY [0..7] OF PDS); +40400 RECR: +40450 (SCOPECR: DEPTHRANGE; +40500 CCOUNTCR: CCOUNTRANGE; +40550 PVALUECR: OBJECTP; +40600 FILLCR1: ELSRANGE; +40650 ANCSTRCR: OBJECTP; +40700 FILLCR2: OBJECTP; +40750 PREV: OBJECTP; +40800 NEXT: OBJECTP; +40810 LBADJCR: BOUNDSRANGE; +40820 MDBLOCKCR: DPOINT; +40830 SIZECR: SIZERANGE; +40840 ROWSCR: 0..7; +40845 DESCVECCR: ARRAY [0..7] OF PDS); +40850 RECN: +40900 (SCOPECN: DEPTHRANGE; +40950 FILLCN: SIZERANGE; +41000 PVALUECN :OBJECTP; +41050 OFFSETCN: ELSRANGE; +41100 ANCESTCN: OBJECTP; +41150 FILLCN3: OBJECTP; +41200 PREVCN: OBJECTP; +41250 NEXTCN: OBJECTP); +41300 STRING: +41350 (FILLST1: DEPTHRANGE; +41400 STRLENGTH: ELSRANGE; +41550 CHARVEC: VECCHARS); +41600 UNDEF, NILL: +41650 (SCOPEUN: DEPTHRANGE; +41700 STRLNGUN: ELSRANGE; +41750 PVALUEUN: OBJECTP; +41800 OFFSETUN: ELSRANGE; +41810 ANCESTUN: OBJECTP; +41850 FILLUN1: OBJECTP; +41860 FILLUN2: OBJECTP; +41870 FILLUN3:OBJECTP; +41880 FILLUN4: BOUNDRANGE; +41885 FILLUN5: DPOINT; +41890 FILLUN6: SIZERANGE; +41895 ROWSUN: 0..7; +41900 DESCVECUN: ARRAY [0..7] OF PDS); +41950 AFILE: (*ACTUALLY, AFILES WILL BE STORED AS STRUCTS, BUT THESE FIELD SELECTORS SHOULD WORK*) +42000 (SCOPEF: DEPTHRANGE; +42050 LENGTHF: SIZERANGE; +42100 DBLOCKF: DPOINT; +42150 LOGICALFILEMENDED: OBJECTP; +42200 PHYSICALFILEMENDED: OBJECTP; +42250 PAGEMENDED: OBJECTP; +42300 LINEMENDED: OBJECTP; +42350 PCOVER: OBJECTP; +42400 TERM: TERMSET); +42450 COVER: +42500 (SCOPEV: DEPTHRANGE; +42550 FILLV: SIZERANGE; +42600 CHANNEL: CHAN; +42650 STATUS: STATUSSET; +42700 POSSIBLES: POSSSET; +42750 COFCPOS, LOFCPOS, POFCPOS: INTEGER; +42800 CHARBOUND, LINEBOUND, PAGEBOUND: INTEGER; +42850 DOPUTS,DOGETS,DONEWLINE,DONEWPAGE,DOSET,DORESET: ASPROC; +42900 CASE ASSOC: BOOLEAN OF +42950 FALSE: (FILLC: SIZERANGE; +42955 BOOK:FETROOMP); +42960 TRUE: (OFFSETDI:SIZERANGE; +42965 ASSREF:OBJECTP; +42970 CPOSELS:ELSRANGE) ); +42975 ); +42980 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ; +42985 END; +42990 ()+03*) +43000 (*+02() +43002 OBJECT = PACKED RECORD +43004 CASE SEVERAL OF +43006 0: (FIRSTPTR: OBJECTP; FILL0: INTEGER); +43008 1: (FIRSTWORD: INTEGER); +43010 2: (PCOUNT: PCOUNTRANGE; +43012 SORT: STRUCTYPE; +43014 CASE STRUCTYPE OF +43016 STRUCT: +43018 (OSCOPE: DEPTHRANGE; +43020 LENGTH: SIZERANGE; +43022 DBLOCK: DPOINT; +43024 RE: REAL; +43026 IM: REAL); +43028 MULT: +43030 (SCOPEM: DEPTHRANGE; +43032 FILLM1: CCOUNTRANGE; +43034 PVALUEM: OBJECTP; +43036 D0: ELSRANGE; +43038 ELS: OBJECTP; +43040 IHEAD: OBJECTP; +43042 BPTR: OBJECTP; +43044 FPTR: OBJECTP; +43046 LBADJ: BOUNDSRANGE; (*(DIST FROM EL[0,...,0] TO 1ST REAL EL) - ELSCONST*) +43048 MDBLOCK: DPOINT; +43050 SIZE: SIZERANGE; +43052 ROWS: 0..7; +43054 DESCVEC: ARRAY [0..7] OF PDS); +43056 IELS: +43058 (OSCOPEE: DEPTHRANGE; +43060 CCOUNT: CCOUNTRANGE; +43062 DBLOCKE: DPOINT; +43066 D0E: ELSRANGE; +43067 FILLE: OBJECTP; +43068 IHEADE: OBJECTP); +43069 ROUTINE: +43070 (SCOPER: DEPTHRANGE; +43072 FILLR: SIZERANGE; +43074 PROCBL: PROCPOINT; +43076 ENVCHAIN: IPOINT); +43078 PASCROUT: +43080 (SCOPEP: DEPTHRANGE; +43082 PPARAMS: SIZERANGE; +43084 PPROCBL: ASPROC ); +43086 REF1: +43088 (SCOPERF1: DEPTHRANGE; +43090 FILLRF1: SIZERANGE; +43091 PVALUER1: OBJECTP; +43092 ANCESTR1: OBJECTP; +43093 OFFSETR1: ELSRANGE; +43094 VALUE: A68INT); +43095 REF2: +43096 (SCOPERF2: DEPTHRANGE; +43098 FILLRF2: SIZERANGE; +43099 PVALUER2: OBJECTP; +43100 ANCESTR2: OBJECTP; +43101 OFFSETR2: ELSRANGE; +43102 LONGVALUE: A68LONG); +43103 REFN: +43104 (SCOPEFN: DEPTHRANGE; +43106 FILLFN: SIZERANGE; +43108 PVALUE: OBJECTP; +43109 ANCESTRN: OBJECTP; +43110 OFFSETRN: ELSRANGE); +43111 CREF: +43112 (SCOPEC: DEPTHRANGE; +43114 FILLCREF: SIZERANGE; +43116 PVALUEC : OBJECTP ; +43117 ANCESTC : OBJECTP ; +43118 IPTR: UNDRESSP); +43120 REFR: +43122 (SCOPERR: DEPTHRANGE; +43124 CCOUNTR: CCOUNTRANGE; +43126 PVALUER: OBJECTP; +43127 ANCESTOR: OBJECTP; +43128 FILLRR1: ELSRANGE; +43129 FILLRR2: OBJECTP; +43130 FILLRR3: OBJECTP; +43131 FILLRR4: OBJECTP; +43132 LBADJRR: BOUNDSRANGE; +43133 MDBLOCKRR: DPOINT; +43134 SIZERR: SIZERANGE; +43135 ROWSRR: 0..7; +43136 DESCVECRR: ARRAY [0..7] OF PDS); +43137 REFSL1: +43138 (SCOPEL: DEPTHRANGE; +43139 CCOUNTL: CCOUNTRANGE; +43140 DBLOCKL: DPOINT; +43142 ANCSTRL: OBJECTP; +43144 OFFSET: ELSRANGE); +43148 REFSLN: +43150 (SCOPEN: DEPTHRANGE; +43152 CCOUNTN: CCOUNTRANGE; +43154 FILLN1: OBJECTP; +43156 ANCSTRN: OBJECTP; +43158 FILLN2: ELSRANGE; +43160 FILLN3: OBJECTP; +43162 FILLN4: OBJECTP; +43164 FILLN5: OBJECTP; +43166 LBADJN: BOUNDSRANGE; +43168 MDBLOCKN: DPOINT; +43170 SIZEN: SIZERANGE; +43172 ROWSN: 0..7; +43174 DESCVECN: ARRAY [0..7] OF PDS); +43176 RECR: +43178 (SCOPECR: DEPTHRANGE; +43180 CCOUNTCR: CCOUNTRANGE; +43182 PVALUECR: OBJECTP; +43184 ANCSTRCR: OBJECTP; +43185 FILLCR1: ELSRANGE; +43186 PREV: OBJECTP; +43187 NEXT: OBJECTP; +43188 FILLCR2: OBJECTP; +43189 LBADJCR: BOUNDSRANGE; +43190 MDBLOCKCR: DPOINT; +43191 SIZECR: SIZERANGE; +43192 ROWSCR: 0..7; +43193 DESCVECCR: ARRAY [0..7] OF PDS); +43194 RECN: +43196 (SCOPECN: DEPTHRANGE; +43198 FILLCN: SIZERANGE; +43200 PVALUECN :OBJECTP; +43202 ANCESTCN: OBJECTP; +43204 OFFSETCN: ELSRANGE; +43208 PREVCN: OBJECTP; +43210 NEXTCN: OBJECTP); +43212 STRING: +43214 (FILLST1: DEPTHRANGE; +43216 STRLENGTH: ELSRANGE; +43222 CHARVEC: VECCHARS); +43226 UNDEF, NILL: +43228 (SCOPEUN: DEPTHRANGE; +43230 STRLNGUN: ELSRANGE; +43232 PVALUEUN: OBJECTP; +43234 ANCESTUN: OBJECTP; +43236 OFFSETUN: ELSRANGE; +43238 FILLUN2: OBJECTP; +43240 FILLUN3: OBJECTP; +43242 FILLUN4: OBJECTP; +43244 FILLUN5: BOUNDSRANGE; +43246 FILLUN6: DPOINT; +43248 FILLUN7: SIZERANGE; +43250 ROWSUN: 0..7; +43252 DESCVECUN: ARRAY [0..7] OF PDS); +43260 AFILE: (*ACTUALLY, AFILES WILL BE STORED AS STRUCTS, BUT THESE FIELD SELECTORS SHOULD WORK*) +43262 (SCOPEF: DEPTHRANGE; +43264 LENGTHF: SIZERANGE; +43266 DBLOCKF: DPOINT; +43268 LOGICALFILEMENDED: OBJECTP; +43270 PHYSICALFILEMENDED: OBJECTP; +43272 PAGEMENDED: OBJECTP; +43274 LINEMENDED: OBJECTP; +43276 PCOVER: OBJECTP; +43278 TERM: TERMSET); +43300 COVER: +43302 (SCOPEV: DEPTHRANGE; +43304 FILLV: SIZERANGE; +43306 CHANNEL: CHAN; +43308 STATUS: STATUSSET; +43310 POSSIBLES: POSSSET; +43312 COFCPOS, LOFCPOS, POFCPOS: INTEGER; +43314 CHARBOUND, LINEBOUND, PAGEBOUND: INTEGER; +43316 DOPUTS,DOGETS,DONEWLINE,DONEWPAGE,DOSET,DORESET: ASPROC; +43318 CASE ASSOC: BOOLEAN OF +43320 FALSE: (FILLC: SIZERANGE; +43322 BOOK:FETROOMP); +43324 TRUE: (OFFSETDI:SIZERANGE; +43326 ASSREF:OBJECTP; +43328 CPOSELS:ELSRANGE) ); +43330 ); +43350 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ; +43360 END; +43370 ()+02*) +43400 ()+12*) +43410 (*+13() +43450 OBJECT = PACKED RECORD +43500 CASE SEVERAL OF +43550 0: (FIRSTPTR: OBJECTP; FILL0: INTEGER); +43600 1: (FIRSTWORD: INTEGER); +43650 2: (PCOUNT: PCOUNTRANGE; +43700 SORT: STRUCTYPE; +43750 CASE STRUCTYPE OF +43800 STRUCT: +43850 (OSCOPE: DEPTHRANGE; +43900 DBLOCK: DPOINT ; (*1*) +44050 LENGTH: CCOUNTRANGE; (*2*) +44100 RE: REAL; +44150 IM: REAL); +44200 MULT: +44250 (OSCOPEM: DEPTHRANGE; +44300 PVALUEM: OBJECTP; (*1*) +44325 FILLM: ELSRANGE; (*2*) +44337 IHEAD: OBJECTP; (*3*) +44350 ROWS: 0..7 ; (*4*) +44400 SIZE: SIZERANGE ; +44450 FILLM1: CCOUNTRANGE ; +44650 BPTR: OBJECTP; (*5*) +44700 FPTR: OBJECTP; (*6*) +44750 LBADJ: BOUNDSRANGE; (*7*) (*(DIST FROM EL[0,...,0] TO 1ST REAL EL) - ELSCONST*) +44800 MDBLOCK: DPOINT; (*8*) +44850 DESCVEC: ARRAY [0..7] OF PDS); +44900 IELS: +44950 (OSCOPEE: DEPTHRANGE; +45000 DBLOCKE: DPOINT; (*1*) +45050 D0: ELSRANGE; (*2*) +45075 IHEADE: OBJECTP; (*3*) +45100 FILLE: CCOUNTRANGE; (*4*) +45150 CCOUNT: CCOUNTRANGE ) ; +45250 ROUTINE: +45300 (OSCOPER: DEPTHRANGE; +45350 PROCBL: PROCPOINT; (*1*) +45400 ENVCHAIN: IPOINT); (*2*) +45450 PASCROUT: +45500 (OSCOPEP: DEPTHRANGE; +45600 PPARAMS: SIZERANGE; (*1*) +45625 PPROCBL: ASPROC ) ; (*2*) +45650 REF1: +45700 (OSCOPERF1: DEPTHRANGE; +45710 PVALUEF1: OBJECTP; (*1*) +45720 ANCSTRF1: OBJECTP; (*2*) +45730 OFFSETF1: ELSRANGE; (*3*) +45750 VALUE: A68INT); (*4*) +45800 REF2: +45850 (SCOPERF2: DEPTHRANGE; +45866 PVALUEF2: OBJECTP; (*1*) +45882 ANCSTRF2: OBJECTP; (*2*) +45890 OFFSETF2: ELSRANGE; (*3*) +45900 LONGVALUE: A68LONG); (*4*) +45950 REFN: +46000 (OSCOPEFN: DEPTHRANGE; +46050 PVALUE: OBJECTP; (*1*) +46060 ANCSTRFN: OBJECTP; (*2*) +46070 OFFSETN: ELSRANGE ) ; (*3*) +46100 CREF: +46150 (SCOPEC: DEPTHRANGE; +46200 PVALUEC : DPOINT ; (*1*) +46210 ANCSTRC: OBJECTP; (*2*) +46250 IPTR: UNDRESSP); (*3*) +46300 REFR: +46350 (OSCOPERR: DEPTHRANGE; +46400 PVALUER: OBJECTP; (*1*) +46410 ANCESTOR: OBJECTP; (*2*) +46420 FILLRR: INTEGER; (*3*) +46450 ROWSRR: 0..7 ; (*4*) +46500 SIZERR: SIZERANGE ; +46550 CCOUNTR: CCOUNTRANGE ; +46600 FILLRR2: OBJECTP ; (*5*) +46700 FILLRR1: OBJECTP ; (*6*) +46710 LBADJRR: BOUNDSRANGE; (*7*) +46720 MDBLOCKRR: DPOINT; (*8*) +46730 DESCVECRR: ARRAY[0..7] OF PDS ) ; +46750 REFSL1: +46800 (OSCOPEL: DEPTHRANGE; +46850 DBLOCKL: DPOINT; (*1*) +46875 ANCSTRL: OBJECTP; (*2*) +46885 OFFSET: ELSRANGE; (*3*) +46900 FILLL: 0..7 ; (*4*) +46950 FILLL1: SIZERANGE ; +47000 CCOUNTL: CCOUNTRANGE); +47200 REFSLN: +47250 (OSCOPEN: DEPTHRANGE; +47300 FILLN: OBJECTP; (*1*) +47325 ANCSTRN: OBJECTP; (*2*) +47340 FILLN1: INTEGER; (*3*) +47350 ROWSN: 0..7 ; (*4*) +47400 SIZEN: SIZERANGE ; +47450 CCOUNTN: CCOUNTRANGE ; +47650 FILLN2: OBJECTP; (*5*) +47700 FILLN3: OBJECTP; (*6*) +47750 LBADJN: BOUNDSRANGE; (*7*) +47800 MDBLOCKN: DPOINT; (*8*) +47850 DESCVECN: ARRAY [0..7] OF PDS); +48200 RECR: +48250 (OSCOPECR: DEPTHRANGE; +48300 PVALUECR: OBJECTP; (*1*) +48325 ANCSTRCR: OBJECTP; (*2*) +48340 FILLCR0: INTEGER; (*3*) +48350 ROWSCR: 0..7 ; (*4*) +48400 SIZECR: SIZERANGE ; +48450 CCOUNTCR: CCOUNTRANGE ; +48650 PREV: OBJECTP; (*5*) +48700 NEXT: OBJECTP; (*6*) +48712 LBADJCR: BOUNDSRANGE; (*7*) +48724 MDBLOCKCR: DPOINT; (*8*) +48736 DESCVECCR: ARRAY [0..7] OF PDS); +48750 RECN: +48800 (OSCOPECN: DEPTHRANGE; +48850 PVALUECN :OBJECTP; (*1*) +48860 ANCSTRCN: OBJECTP; (*2*) +48950 OFFSETCN: ELSRANGE; (*3*) +49000 FILLCN2: INTEGER; (*4*) +49100 PREVCN: OBJECTP; (*5*) +49150 NEXTCN: OBJECTP); (*6*) +49200 STRING: +49250 (FILLSTG: DEPTHRANGE; +49275 FILLSTG1: ARRAY [1..3] OF INTEGER; (*1*) +49325 FILLSTG2: CCOUNTRANGE; (*4*) +49350 STRLENGTH: CCOUNTRANGE; +49400 CHARVEC: VECCHARS); (*5*) +49450 UNDEF, NILL: +49500 (OSCOPEUN: DEPTHRANGE; +49550 PVALUEUN: OBJECTP; +49560 ANCSTRUN: OBJECTP; +49570 OFFSETUN: ELSRANGE; +49580 ROWSUN: 0..7; +49600 STRLNGUN: CCOUNTRANGE; +49650 FILLUN: ARRAY [1..4] OF INTEGER; +49700 DESCVECUN: ARRAY [0..7] OF PDS); +49750 AFILE: (*ACTUALLY, AFILES WILL BE STORED AS STRUCTS, BUT THESE FIELD SELECTORS SHOULD WORK*) +49800 (SCOPEF: DEPTHRANGE; +49850 DBLOCKF: DPOINT; +49900 FILLAF: 0..7 ; +49950 FILLAF1: SIZERANGE ; +50000 LENGTHF: CCOUNTRANGE ; +50050 LOGICALFILEMENDED: OBJECTP; +50100 PHYSICALFILEMENDED: OBJECTP; +50150 PAGEMENDED: OBJECTP; +50200 LINEMENDED: OBJECTP; +50250 PCOVER: OBJECTP; +50300 TERM: TERMSET); +50350 COVER: +50400 (SCOPEV: DEPTHRANGE; +50450 CHANNEL: CHAN; +50500 STATUS: STATUSSET; +50550 POSSIBLES: POSSSET; +50600 COFCPOS, LOFCPOS, POFCPOS: INTEGER; +50650 CHARBOUND, LINEBOUND, PAGEBOUND: INTEGER; +50700 DOPUTS,DOGETS,DONEWLINE,DONEWPAGE,DOSET,DORESET: ASPROC; +50750 CASE ASSOC: BOOLEAN OF +50800 FALSE: (FILLC: SIZERANGE; +50850 BOOK:FETROOMP); +50900 TRUE: (OFFSETDI:SIZERANGE; +50950 ASSREF:OBJECTP; +51000 CPOSELS:ELSRANGE) ); +51050 ); +51100 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ; +51150 END; +51200 ()+13*) +51250 (**) +51300 (**) +51350 (**) +51400 (**) +51450 (**) +51500 (**) +51550 (**) +51600 (**) +51650 (**) +51700 (**) +51750 (**) +51800 (**) +51850 (**) +51900 (**) +51950 (**) +52000 (**) +52050 (**) +52100 (**) +52150 (**) +52200 (**) +52250 (**) +52300 (**) +52350 (**) +52400 (**) +52450 (**) +52500 (**) +52550 (**) +52600 (**) +52650 (**) +52700 (**) +52750 (**) +52800 (**) +52850 (**) +52900 (**) +52950 (**) +53000 (*********************) +53050 (* INVOCATION BLOCKS *) +53100 (*********************) +53150 (**) +53200 (*+11() ADDRESS = 0..777777B; ()+11*) +53250 (*+12() ADDRESS = (*-19()INTEGER;()-19*) (*+19()LONG;()+19*) ()+12*) +53300 (*+13() ADDRESS = INTEGER ; ()+13*) +53350 CONVBLE = (POINT, INT); +53400 SIMPILE = +53450 RECORD CASE CONVBLE OF +53500 INT: (SIM: IPOINT); +53550 POINT: (PIL: OBJECTP) +53600 END; +53650 (**) +53700 (**) +53750 BITMAP = PACKED RECORD +53800 (*+11() +53850 FILL: 0..77777777777777B; +53900 MASK: -17777B..+17777B; +53950 ()+11*) +54000 (*+12() (*+03() +54050 MASK: -3777B..+3777B; (*DIFFICULTIES ON NORD*) +54055 ()+03*) +54060 (*+02() +54070 MASK: INTEGER; +54075 COUNT: INTEGER; +54080 ()+02*) +54100 ()+12*) +54150 (*+13() (*+02() +54200 MASK: -32768..+32767 ; +54210 COUNT: -32768..32767; +54250 ()+02*) +54300 (*-02() COUNT: 0..15 ; +54301 ()-02*) ()+13*) +54350 END; +54400 PIDBLK = ^IDBLK; +54450 IDBLK=PACKED RECORD +54451 CASE SEVERAL OF +54500 1: (ALF: (*+01() ALFA; ()+01*) (*-01() PACKED ARRAY [1..10] OF CHAR; ()-01*) ); +54550 2: (A,B,C,D,E,F,G,H,I,J:BYTE; +54551 IDSIZE: BYTE; +54600 XMODE: BYTE); +54601 3,4,5,6,7,8,9,10: (); +54650 END; +54700 PRANGE = ^RANGEBLOCK; +54750 RANGEBLOCK = +54800 RECORD +54850 FIRSTW: PACKED RECORD +54860 (*+11() FILL: 0..177B; +54870 LOOPCOUNT: 0..377777B; +54880 FILL1: 0..1; +54890 ()+11*) +55000 (*-11() LOOPCOUNT: INTEGER; ()-11*) +55050 RGIDBLK: PIDBLK; +55100 (*+11() FILL2: 0..1; ()+11*) +55150 RECGEN: OBJECTP +55200 END; +55250 RGSCOPE: DEPTHRANGE; +55300 RIBOFFSET: PRANGE; +55350 (*-41() RGNEXTFREE: INTPOINT ; ()-41*) +55400 (*+41() RGLASTUSED: INTPOINT ; ()+41*) +55450 END; +55500 INVBLOCK = (*THIS RECORD IS FOR INFORMATION ONLY. IT IS NOT USED BY THE RUN-TIME SYSTEM*) +55550 RECORD +55600 (*+01() +55650 PASCAL: PACKED RECORD +55700 STATICCHAIN: IPOINT; +55750 A68BIT: BOOLEAN;PUTBIT: BOOLEAN;GETBIT: BOOLEAN; FILL2: 0..17777777B; DYN: ^INVBLOCK; RETURN: ADDRESS +55800 END; +55850 ()+01*) +55900 (*+03() +55950 PASCAL: PACKED RECORD +56000 WORD1,WORD2,WORD3: INTEGER; +56050 OLDB,OLDPC,OLDEP: INTEGER; +56100 STATICCHAIN, DYN: IPOINT; +56150 OLDLNR: INTEGER; +56200 (* WE NEED A68BIT AT LEAST - HOPEFULLY PUTBIT AND GETBIT ALSO ----------*) +56250 END; +56300 ()+03*) +56350 SPARE: INTEGER; +56400 SCOPE: DEPTHRANGE; +56450 NPARAMS: INTEGER; +56500 BITPATTERN: BITMAP; +56550 TRACE: OBJECTP; +56600 LEVEL: INTEGER; +56650 PROCBL: PROCPOINT; +56700 LINENO: INTEGER; +56750 FIRSTRG: RANGEBLOCK; +56800 END; +56850 (**) +56900 (*********************) +56950 (* OTHER BLOCKS *) +57000 (*********************) +57050 (**) +57100 PROCBLOCK = +57150 RECORD +57200 XBASE: ADDRESS; +57250 LEVEL: INTEGER; +57300 SCOFFSET: INTEGER; +57350 SCOPELEVEL: INTEGER; +57400 IBSIZE: INTEGER; +57450 PARAMS:INTEGER; +57500 ROUTNAME: IDBLK; +57550 IDBLOCK: PIDBLK; +57600 END; +57650 (* *) +57700 DEEBLOCK = +57750 ARRAY[0..999] OF INTEGER; +57800 (**) +57850 PDESC= +57900 RECORD +57950 PSIZE: OFFSETRANGE; +58000 ACCOFFS: BOUNDSRANGE; +58050 PROWS: 0..7; +58100 PDESCVEC: ARRAY [0..7] OF RECORD +58150 PP, PD, PL, PND: INTEGER; +58200 END +58250 END; +58300 (**) +58350 NAKED = +58400 PACKED RECORD +58450 (*+11() BIT0: BOOLEAN; (*THIS BIT MUST ALWAYS BE ZERO, FOR BENEFIT OF COMPILED CODE*) ()+11*) +58500 STOWEDVAL: OBJECTP; +58550 (*+11() FILL: 0..177777777B; ()+11*) +58600 CASE SEVERAL OF +58650 0: (POSITION: ELSRANGE); +58700 1: (POINTER: UNDRESSP); (*SPECIAL FORM, AS USED IN DISPLAYS*) +58750 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ; +58800 END; +58850 (*+01() ASNAKED = INTEGER; ()+01*) (*OR WHATEVER SCALAR TYPE CAN ENCOMPASS A NAKED*) +58900 (*-01() ASNAKED = REAL; (*MOST MACHINES REQUIRE TWO WORDS FOR THIS*) ()-01*) +58950 NAKEGER = +59000 RECORD CASE CONVBLE OF +59050 INT: (ASNAK: ASNAKED); +59100 POINT: (NAK: NAKED); +59150 END; +59152 (**) +59160 PPROC = (*REPRESENTATION OF PASCAL PROCEDURE/FUNCTION VALUE*) +59162 PACKED RECORD +59163 (*+01() FILLER:0..77777777B; ()+01*) +59164 (*-02() ENV: ADDRESS; +59165 PROCADD: ADDRESS; ()-02*) +59166 (*+02() PROCADD: ADDRESS; +59167 ENV: ADDRESS; ()+02*) +59168 END; +59170 (**) +59200 REALTEGER = +59250 RECORD CASE SEVERAL OF +59300 0: (INT: INTEGER (*-01(); INT2: INTEGER ()-01*)); +59350 (*-01() 1: (LONG: A68LONG); ()-01*) +59400 2: (REA: REAL); +59450 3: (ALF: PACKED ARRAY [ 1..BYTESWIDTH ] OF CHAR); +59500 4: (CH: CHAR); +59550 5: (PTR: OBJECTP); +59600 6: (PROCC: ASPROC); +59610 7: (PROCVAL: PPROC); +59650 8 , 9 , 10 : () ; +59700 END; +59750 (*+01() +59800 MESS = PACKED ARRAY [1..50] OF CHAR; (*FOR PASCPMD*) +59850 W66 = PACKED RECORD +59900 FILL1: 0..77777777B; JOPR: 0..7777B; FILL2: 0..77777777B; +59950 END; +60000 ()+01*) +60040 (**) +60050 BYLPP = ^BYLP; +60051 NOBYLPP = ^NOBYLP; +60052 BYLP = RECORD +60054 (*-41() +60056 LOOPTYP: INTEGER; +60058 BYPART: A68INT; +60060 FROMPART: A68INT; +60062 TOPART: A68INT; +60064 ()-41*) +60066 (*+41() +60068 TOPART: A68INT; +60070 FROMPART: A68INT; +60072 BYPART: A68INT; +60074 LOOPTYP: INTEGER; +60076 ()+41*) +60078 END; +60080 NOBYLP = RECORD +60082 (*-41() +60084 LOOPTYP: INTEGER; +60086 FROMPART: A68INT; +60088 TOPART: A68INT; +60090 ()-41*) +60092 (*+41() +60094 TOPART: A68INT; +60096 FROMPART: A68INT; +60097 LOOPTYP: INTEGER; +60098 ()+41*) +60099 END; +60100 (**) +60150 VAR (* VAR VAR VAR VAR VAR VAR VAR VAR VAR *) +60200 (**) +60250 UNINT: INTEGER; +60300 UNDEFIN: OBJECTP; +60350 PASCPARAMS: SIZERANGE ; +60400 PASCPROC: ASPROC; +60450 (*-02() (*THE ABOVE VARIABLES MUST BE DECLARED FIRST BECAUSE THE COMPILED CODE +60500 AND/OR MACHINE CODE ROUTINES KNOW ABOUT THEM*) ()-02*) +60550 PASCADDR: PROCPOINT; (*A68-STYLE PROCBLOCK REPRESENTING PASCAL ROUTINE*) +60600 ALLCHAR (*+01() , ALLCHAR1 ()+01*): TERMSET; +60650 HALFPI: ACCURATEPI; +60700 COMPLEX: DPOINT; (*FOR WIDENING TO .COMPL*) +60750 FILEBLOCK: DPOINT; +60800 (*-01() +60850 SOURDESC, SLICDESC: OBJECTP; (*GLOBAL VARIABLES FOR SLICING*) +60900 SOURDEX, SLICDEX: 0..7; (*DITTO*) +60950 ADJACC: BOUNDSRANGE; (*DITTO*) +61000 REVISEDLB: BOUNDSRANGE; (*DITTO*) +61050 SLICEPDS: PDS; (*DITTO*) +61150 ()-01*) +61200 PUTSTRING, HIGHPCOUNT: OBJECTP; +61250 SPARE2, NILPTR: OBJECTP; +61300 BITP: BITMAP; +61350 (*-54() SPARE1: IPOINT; ()-54*) +61400 (*+54() EXCEPTDB: DPOINT; ()+54*) +61410 (*+02() INTUNDEF: INTEGER; ()+02*) +61450 CPUCLOCK: INTEGER; +61500 (*THIS IS MERELY TO MAP OUT ENOUGH SPACE BEFORE THE NEXT VARIABLES, WHICH ARE ALSO KNOWN TO THE A68 PROGRAM*) +61550 FIRSTIB: INVBLOCK; (*FIRSTIBOFFSET MUST ACCESS THIS VARIABLE*) +61600 (*+01() +61650 LASTRANDOM: INTEGER; (*START OF STANDARD-PRELUDE*) +61700 STIN: OBJECTP; +61750 STOUT: OBJECTP; +61800 STBACK: OBJECTP; +61850 ()+01*) +61900 (**) +61905 (*+02() +61910 FUNCTION TIMESTE (T:REAL; E:INTEGER) :REAL; EXTERN; +61945 ()+02*) +61950 (**) +62000 (*+01() (*$E+*) ()+01*) +62050 (**) +62100 (**) +62150 (*+01() (*$X4*) ()+01*) +62200 (**) +62400 (*+01() PROCEDURE A68 ; ()+01*) +62450 (*+05() +62500 PROCEDURE A68( BITPATTERN: BITMAP ; LOCRG: DEPTHRANGE; PROCBL: PROCPOINT; STATICP: IPOINT); +62550 ()+05*) +62560 (*+02() +62570 PROCEDURE A68(UNINTCOPY: INTEGER; UNDEFINCOPY: OBJECTP; BITPATTERN: BITMAP; +62575 LOCRG: DEPTHRANGE; PROCBL: PROCPOINT; STATICP: IPOINT); +62580 ()+02*) +62600 (*THIS REPRESENTS THE A68 PROCEDURE (OR MAIN PROGRAM) FROM WHICH RUN-TIME ROUTINES (OCODES) +62650 GET CALLED. ALL RUN-TIME ROUTINES ARE DECLARED WITHIN A68, AND THE COMPILER ARRANGES THAT +62700 THEIR STATIC LINKS WILL ALWAYS POINT TO THE CALLING A68 ROUTINE. THUS THE VARIABLES ABOUT +62750 TO BE DECLARED ARE ALL ACCESSIBLE, AND WILL ACTUALLY BE PART OF THE INVOCATION BLOCK OF +62800 THE CALLING A68 PROCEDURE. +62850 *) +62900 (*+01() +62950 VAR SCOPE: DEPTHRANGE; +63000 SPARE: INTEGER; +63050 BITPATTERN: BITMAP; +63100 TRACE: OBJECTP; +63150 LEVEL: INTEGER; +63200 PROCBL: PROCPOINT; +63250 LINENO: INTEGER; +63300 FIRSTRG: RANGEBLOCK; +63350 ()+01*) +63400 (*+05() +63450 VAR +63500 SCOPE: INTEGER ; +63550 TRACE: OBJECTP ; +63600 LEVEL: INTEGER ; +63650 LINENO: INTEGER ; +63700 FIRSTRG: RANGEBLOCK ; +63750 (*THIS IS MERELY TO MAP OUT ENOUGH SPACE BEFORE THE NEXT VARIABLES, WHICH ARE ALSO KNOWN TO THE A68 PROGRAM*) +63800 LASTRANDOM: INTEGER; (*START OF STANDARD-PRELUDE*) +63850 STIN: OBJECTP; +63900 STOUT: OBJECTP; +63950 STBACK: OBJECTP; +64000 ()+05*) +64002 (*+02() +64004 VAR +64006 SCOPE: INTEGER ; +64008 TRACE: OBJECTP ; +64010 LEVEL: INTEGER ; +64012 LINENO: INTEGER ; +64014 FIRSTRG: RANGEBLOCK ; +64016 (*THIS IS MERELY TO MAP OUT ENOUGH SPACE BEFORE THE NEXT VARIABLES, WHICH ARE ALSO KNOWN TO THE A68 PROGRAM*) +64018 LASTRANDOM: INTEGER; (*START OF STANDARD-PRELUDE*) +64020 STIN: OBJECTP; +64021 STOUT: OBJECTP; +64022 STBACK: OBJECTP; +64024 MAXREAL: REAL +64025 SMALLREAL: REAL; +64026 PI: REAL; +64026 ()+02*) +64050 (**) +64100 (*ALL THE PROCEDURES AND FUNCTIONS WHICH FOLLOW ARE WITHIN A68*) +64150 (**) +64200 (**) +64300 FUNCTION ME: IPOINT; EXTERN; (*STACK FRAME POINTER OF CALLER*) +64350 FUNCTION STATIC(IB: IPOINT): IPOINT; EXTERN; (*FOLLOW STATIC CHAIN*) +64400 (*+05() FUNCTION A68STATIC(IB: IPOINT): IPOINT; EXTERN; (*FOLLOW ALGOL 68S STATIC CHAIN*) ()+05*) +64450 FUNCTION DYNAMIC(IB: IPOINT): IPOINT; EXTERN; (*FOLLOW DYNAMIC CHAIN*) +64452 (*+02() FUNCTION ARGBASE(IB: IPOINT): IPOINT; EXTERN; ()+02*) +64500 FUNCTION ISA68(IB: IPOINT): BOOLEAN; EXTERN; (*IB IS FRAME FOR A68 PROC*) +64550 FUNCTION ISPUT(IB: IPOINT): BOOLEAN; EXTERN; (*IB IS FRAME FOR CALL OF PUTT*) +64600 FUNCTION ISGET(IB: IPOINT): BOOLEAN; EXTERN; (*IB IS FRAME FOR CALL OF GETT*) +64650 PROCEDURE SETMYSTATIC(IB: IPOINT); EXTERN; (*SETS STATIC CHAIN OF CALLER*) diff --git a/lang/a68s/liba68s/safeaccess.p b/lang/a68s/liba68s/safeaccess.p new file mode 100644 index 000000000..3036fb53a --- /dev/null +++ b/lang/a68s/liba68s/safeaccess.p @@ -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= 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)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*) diff --git a/lang/a68s/liba68s/scopext.p b/lang/a68s/liba68s/scopext.p new file mode 100644 index 000000000..9fe89bc29 --- /dev/null +++ b/lang/a68s/liba68s/scopext.p @@ -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*) diff --git a/lang/a68s/liba68s/selectr.p b/lang/a68s/liba68s/selectr.p new file mode 100644 index 000000000..baaa8db9d --- /dev/null +++ b/lang/a68s/liba68s/selectr.p @@ -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*) diff --git a/lang/a68s/liba68s/selecttsn.p b/lang/a68s/liba68s/selecttsn.p new file mode 100644 index 000000000..f74058298 --- /dev/null +++ b/lang/a68s/liba68s/selecttsn.p @@ -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*) diff --git a/lang/a68s/liba68s/setcc.p b/lang/a68s/liba68s/setcc.p new file mode 100644 index 000000000..5b7e03030 --- /dev/null +++ b/lang/a68s/liba68s/setcc.p @@ -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*) diff --git a/lang/a68s/liba68s/sett.p b/lang/a68s/liba68s/sett.p new file mode 100644 index 000000000..f2ed07d0d --- /dev/null +++ b/lang/a68s/liba68s/sett.p @@ -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*) diff --git a/lang/a68s/liba68s/shl.c b/lang/a68s/liba68s/shl.c new file mode 100644 index 000000000..7b50aafbf --- /dev/null +++ b/lang/a68s/liba68s/shl.c @@ -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 ) ; } diff --git a/lang/a68s/liba68s/shr.c b/lang/a68s/liba68s/shr.c new file mode 100644 index 000000000..f28096581 --- /dev/null +++ b/lang/a68s/liba68s/shr.c @@ -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 ) ; } diff --git a/lang/a68s/liba68s/signi.c b/lang/a68s/liba68s/signi.c new file mode 100644 index 000000000..d3f404149 --- /dev/null +++ b/lang/a68s/liba68s/signi.c @@ -0,0 +1,4 @@ +SIGNI(statlink, n) + int *statlink ; + int n ; + { return( n < 0 ? - 1 : n == 0 ? 0 : 1 ) ; } diff --git a/lang/a68s/liba68s/signr.c b/lang/a68s/liba68s/signr.c new file mode 100644 index 000000000..1c2b7df87 --- /dev/null +++ b/lang/a68s/liba68s/signr.c @@ -0,0 +1,4 @@ +SIGNR(statlink, n) + int *statlink ; + register double n ; + { return( n < 0.0 ? - 1 : n == 0.0 ? 0 : 1 ) ; } diff --git a/lang/a68s/liba68s/sin.c b/lang/a68s/liba68s/sin.c new file mode 100644 index 000000000..e3389b61e --- /dev/null +++ b/lang/a68s/liba68s/sin.c @@ -0,0 +1,4 @@ +extern double _sin(); +double SIN(statlink, x) + int *statlink; double x; + {return(_sin(x));} diff --git a/lang/a68s/liba68s/skip.p b/lang/a68s/liba68s/skip.p new file mode 100644 index 000000000..fd8869cae --- /dev/null +++ b/lang/a68s/liba68s/skip.p @@ -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*) diff --git a/lang/a68s/liba68s/slice12.p b/lang/a68s/liba68s/slice12.p new file mode 100644 index 000000000..e5e34e245 --- /dev/null +++ b/lang/a68s/liba68s/slice12.p @@ -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
  • 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 (INDEXUI) 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 (INDEX2UI) THEN SLCMN(STOWEDVAL, INDEX2, 0) +48810 ELSE OFFS := -LBADJ+DI*INDEX2; +48820 WITH DESCVEC[1] DO +48830 IF (INDEX1UI) 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*) diff --git a/lang/a68s/liba68s/slicen.p b/lang/a68s/liba68s/slicen.p new file mode 100644 index 000000000..1a7849da3 --- /dev/null +++ b/lang/a68s/liba68s/slicen.p @@ -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 (INDEXUI) 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*) diff --git a/lang/a68s/liba68s/space.p b/lang/a68s/liba68s/space.p new file mode 100644 index 000000000..027ea93a3 --- /dev/null +++ b/lang/a68s/liba68s/space.p @@ -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*) diff --git a/lang/a68s/liba68s/sqrt.c b/lang/a68s/liba68s/sqrt.c new file mode 100644 index 000000000..4cf485a18 --- /dev/null +++ b/lang/a68s/liba68s/sqrt.c @@ -0,0 +1,4 @@ +extern double _sqrt(); +double SQRT(statlink, x) + int *statlink; double x; + {return(_sqt(x));} diff --git a/lang/a68s/liba68s/standass.p b/lang/a68s/liba68s/standass.p new file mode 100644 index 000000000..7d60023b6 --- /dev/null +++ b/lang/a68s/liba68s/standass.p @@ -0,0 +1,112 @@ +89300 #include "rundecs.h" +89310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +89320 (**) +89330 PROCEDURE TESTCC(TARGET:OBJECTP); EXTERN; +89340 (**) +89350 (**) +89360 PROCEDURE ASSWRSTR(COV,PUTSTRING:OBJECTP;LB,UB:INTEGER; VAR FYLE :FYL); +89370 VAR PTR: UNDRESSP; +89380 I,CP,OFS,WIDTH:INTEGER; +89390 BEGIN WITH COV^ DO +89400 BEGIN +89410 CP:=CPOSELS; +89420 OFS:=OFFSETDI; +89430 IF FPTWO(ASSREF^.ANCESTOR^) THEN +89440 TESTCC(ASSREF); +89450 PTR := INCPTR(ASSREF^.ANCESTOR^.PVALUE, CP); +89460 IF LB<0 THEN +89470 BEGIN PTR^.FIRSTWORD:=UB; CP:=CP+OFS; WIDTH:=1 END +89480 ELSE BEGIN WIDTH:=UB-LB+1; +89490 WITH PUTSTRING^ DO +89500 FOR I := LB TO UB DO +89510 BEGIN PTR^.FIRSTWORD:=ORD(CHARVEC[I]); +89520 PTR := INCPTR(PTR, OFS); +89530 CP:=CP+OFS +89540 END; +89550 END; +89560 COFCPOS:=COFCPOS+WIDTH; +89570 CPOSELS:=CP; +89580 IF COFCPOS>CHARBOUND THEN +89590 STATUS:=STATUS+[LINEOVERFLOW]; +89600 END; +89610 END; +89620 (**) +89630 (**) +89640 PROCEDURE ASSRDSTR( +89650 PCOV: OBJECTP; VAR CHARS: GETBUFTYPE; T (*+01(), T1()+01*): TERMSET; VAR I: INTEGER; VAR FYLE: FYL +89660 ); +89670 VAR PTR: UNDRESSP; +89680 CH: CHAR; +89690 (*LINEOK*) +89700 BEGIN +89710 WITH PCOV^ DO +89720 BEGIN +89730 PTR := INCPTR(ASSREF^.ANCESTOR^.PVALUE, CPOSELS); +89740 IF I<0 THEN +89750 BEGIN I := PTR^.FIRSTWORD; CPOSELS := CPOSELS+OFFSETDI; COFCPOS := COFCPOS+1 END +89760 ELSE +89770 BEGIN +89780 CH := CHR(PTR^.FIRSTWORD); +89790 WHILE (COFCPOS<=CHARBOUND) AND NOT(CH IN T) +89800 (*+01() AND ((ORD(CH)<=59) OR NOT(CHR(ORD(CH)-59) IN T1)) ()+01*) DO +89810 BEGIN +89820 CHARS[I] := CH; I := I+1; +89830 CPOSELS := CPOSELS+OFFSETDI; +89840 PTR := INCPTR(PTR, OFFSETDI); +89850 CH := CHR(PTR^.FIRSTWORD); +89860 COFCPOS := COFCPOS+1; +89870 END +89880 END; +89890 IF COFCPOS>CHARBOUND THEN +89900 STATUS := STATUS+[LINEOVERFLOW]; +89910 END +89920 END; +89930 (**) +89940 (**) +89950 PROCEDURE ASSNEWLINE(COV: OBJECTP; VAR FYLE: FYL); +89960 BEGIN WITH COV^ DO +89970 BEGIN +89980 LOFCPOS := 2; COFCPOS := 1; +89990 STATUS := STATUS+[PAGEOVERFLOW,LINEOVERFLOW]; +90000 END +90010 END; +90020 (**) +90030 (**) +90040 PROCEDURE ASSNEWPAGE(COV: OBJECTP; VAR FYLE: FYL); +90050 BEGIN WITH COV^ DO +90060 BEGIN +90070 POFCPOS := 2; LOFCPOS := 1; COFCPOS := 1; +90080 IF READMOOD IN STATUS THEN STATUS := STATUS+[LFE,PAGEOVERFLOW,LINEOVERFLOW] +90090 ELSE STATUS := STATUS+[PFE,PAGEOVERFLOW,LINEOVERFLOW]; +90100 END +90110 END; +90120 (**) +90130 (**) +90140 PROCEDURE ASSRESET(COV: OBJECTP; VAR FYLE: FYL); +90150 BEGIN WITH COV^.ASSREF^ DO +90160 COV^.CPOSELS := DESCVEC[0].DI-LBADJ; +90170 END; +90180 (**) +90190 (**) +90200 PROCEDURE ASSSET(COV: OBJECTP; P, L, C: INTEGER; VAR FYLE: FYL); +90210 BEGIN WITH COV^ DO +90220 BEGIN +90230 COFCPOS := C; LOFCPOS := L; POFCPOS := P; +90240 STATUS := STATUS-[LFE,PFE,PAGEOVERFLOW,LINEOVERFLOW]; +90250 IF POFCPOS>PAGEBOUND THEN ASSNEWPAGE(COV, FYLE) +90260 ELSE IF LOFCPOS>LINEBOUND THEN ASSNEWLINE(COV, FYLE) +90270 ELSE IF COFCPOS>CHARBOUND THEN STATUS := STATUS+[LINEOVERFLOW] +90280 ELSE WITH ASSREF^ DO +90290 COV^.CPOSELS := C*DESCVEC[0].DI-LBADJ; +90300 END +90310 END; +90320 (**) +90330 (**) +90340 (*-02() +90350 BEGIN (*OF A68*) +90360 END; (*OF A68*) +90370 ()-02*) +90380 (*+01() +90390 BEGIN (*OF MAIN PROGRAM*) +90400 END (*OF EVERYTHING*). +90410 ()+01*) diff --git a/lang/a68s/liba68s/standback.e b/lang/a68s/liba68s/standback.e new file mode 100644 index 000000000..5a036fae0 --- /dev/null +++ b/lang/a68s/liba68s/standback.e @@ -0,0 +1,7 @@ +#include "e.h" + + exp $STANDBAC + + pro $STANDBAC,0 + ret 0 + end 0 diff --git a/lang/a68s/liba68s/standin.p b/lang/a68s/liba68s/standin.p new file mode 100644 index 000000000..9de78d7b9 --- /dev/null +++ b/lang/a68s/liba68s/standin.p @@ -0,0 +1,73 @@ +90500 #include "rundecs.h" +90510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +90520 (**) +90530 (**) +90540 PROCEDURE SETSTATUS(COV:OBJECTP; VAR FYLE: FYL); +90550 VAR STAT:STATUSSET; +90560 BEGIN +90570 IF NOTINITIALIZED IN COV^.STATUS THEN STAT := [NOTINITIALIZED,LFE,PAGEOVERFLOW,LINEOVERFLOW] +90580 ELSE IF EOF(FYLE) THEN STAT := [LFE,PAGEOVERFLOW,LINEOVERFLOW] +90590 ELSE IF (*-50()FYLE^=CHR(12)()-50*) (*+50()EOS(FYLE)()+50*) THEN +90600 STAT := [PAGEOVERFLOW,LINEOVERFLOW] +90610 ELSE IF EOLN(FYLE) THEN STAT := [LINEOVERFLOW] +90620 ELSE STAT := []; +90630 COV^.STATUS:=COV^.STATUS-[NOTINITIALIZED,LFE,PAGEOVERFLOW,LINEOVERFLOW]+STAT; +90640 END; +90650 (**) +90660 (**) +90670 (*******STAND IN PRIMITVES*******) +90680 (**) +90690 (**) +90700 PROCEDURE SIRDSTR( +90710 PCOV: OBJECTP ; VAR CHARS: GETBUFTYPE ; T (*+01() , T1 ()+01*): TERMSET ; VAR I: INTEGER ; VAR FYLE: FYL +90720 ) ; +90730 (*LINEOK*) +90740 BEGIN WITH PCOV^ DO +90750 IF I<0 THEN +90760 BEGIN I := ORD(FYLE^); GET(FYLE); COFCPOS := COFCPOS+1 END +90770 ELSE +90780 WHILE NOT EOLN(FYLE) AND NOT (FYLE^ IN T) +90790 (*+01() AND ((ORD(FYLE^)<=59) OR NOT (CHR(ORD(FYLE^)-59) IN T1)) ()+01*) DO +90800 BEGIN CHARS[I] := FYLE^; I := I+1; GET(FYLE); COFCPOS := COFCPOS+1 END; +90810 SETSTATUS(PCOV, FYLE) +90820 END; +90830 (**) +90840 (**) +90850 PROCEDURE SINEWLINE(COV:OBJECTP; VAR FYLE :FYL); +90860 BEGIN WITH COV^ DO +90870 BEGIN READLN(FYLE); +90880 LOFCPOS:=LOFCPOS+1; +90890 COFCPOS:=1; +90900 STATUS := STATUS-[NOTINITIALIZED]; +90910 END; +90920 SETSTATUS(COV, FYLE) +90930 END; +90940 (**) +90950 (**) +90960 PROCEDURE SINEWPAGE(COV:OBJECTP; VAR FYLE :FYL); +90970 BEGIN WITH COV^ DO +90980 BEGIN +90990 (*-50() WHILE FYLE^<>CHR(12) DO GET(FYLE); GET(FYLE); ()-50*) +91000 (*+50() GETSEG(FYLE) ; ()+50*) +91010 COFCPOS:=1; LOFCPOS:=1; POFCPOS:=POFCPOS+1; +91020 END; +91030 SETSTATUS(COV, FYLE) +91040 END; +91050 (**) +91060 (**) +91070 PROCEDURE SIRESET(COV: OBJECTP; VAR FYLE: FYL); +91080 (*OPENED,MOODOK*) +91090 BEGIN WITH COV^ DO +91100 IF RESETPOSS IN POSSIBLES THEN +91110 BEGIN RESET(FYLE); SETSTATUS(COV, FYLE) END +91120 END; +91130 (**) +91140 (**) +91150 (*-02() +91160 BEGIN (*OF A68*) +91170 END; (*OF A68*) +91180 ()-02*) +91190 (*+01() +91200 BEGIN (*OF MAIN PROGRAM*) +91210 END (*OF EVERYTHING*). +91220 ()+01*) diff --git a/lang/a68s/liba68s/standout.p b/lang/a68s/liba68s/standout.p new file mode 100644 index 000000000..cabb4226b --- /dev/null +++ b/lang/a68s/liba68s/standout.p @@ -0,0 +1,152 @@ +91300 #include "rundecs.h" +91310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +91320 (**) +91330 (*+05() PROCEDURE FLSBUF(P: PCFILE; CH: CHAR); EXTERN; ()+05*) +91340 (*+02() +91350 PROCEDURE STOPEN (VAR PF: FYL; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH(COV:OBJECTP;L:LFNTYPE) ); EXTERN; +91360 ()+02*) +91370 (**) +91380 (**) +91390 (**) +91400 (*******STAND OUT PRIMITIVES*******) +91410 PROCEDURE SONEWLINE(COV:OBJECTP; VAR FYLE :FYL); +91420 (*+05() +91430 PROCEDURE WRC(P: PCFILE; CH: CHAR); EXTERN; +91440 ()+05*) +91450 BEGIN WITH COV^ DO +91460 BEGIN LOFCPOS:=LOFCPOS+1; +91470 COFCPOS:=1; +91480 (*+05() +91490 WITH BOOK^ DO +91500 IF (*ISTTY*) (XFILE^.FLAG DIV 512) MOD 2 <> 0 THEN +91510 FLSBUF(XFILE, CHR(10)) +91520 ELSE WRC(XFILE, CHR(10)); +91530 ()+05*) +91540 (*-05() WRITELN(FYLE); ()-05*) +91550 IF LOFCPOS>LINEBOUND THEN STATUS:=STATUS+[PAGEOVERFLOW,LINEOVERFLOW] +91560 ELSE BEGIN STATUS:=STATUS-[LINEOVERFLOW]; +91570 IF CARRIAGE IN STATUS THEN WRITE(FYLE, ' ') +91580 END +91590 END +91600 END; +91610 (**) +91620 (**) +91630 PROCEDURE SONEWPAGE(COV:OBJECTP; VAR FYLE :FYL); +91640 VAR I: INTEGER; +91650 BEGIN WITH COV^ DO +91660 BEGIN +91670 IF COFCPOS<>1 THEN SONEWLINE(COV, FYLE); +91680 (*+05() +91690 IF (*ISTTY*) (BOOK^.XFILE^.FLAG DIV 512) MOD 2 <> 0 THEN +91700 FOR I := LOFCPOS TO LINEBOUND DO SONEWLINE(COV, FYLE) +91710 ELSE +91720 ()+05*) +91730 (*-50() PAGE(FYLE); ()-50*) +91740 (*+50() PUTSEG(FYLE); ()+50*) +91750 COFCPOS:=1; LOFCPOS:=1; POFCPOS:=POFCPOS+1; +91760 STATUS:=STATUS-[PAGEOVERFLOW,LINEOVERFLOW]; +91770 IF POFCPOS>PAGEBOUND THEN +91780 STATUS:=STATUS+[PFE,PAGEOVERFLOW,LINEOVERFLOW] +91790 ELSE IF CARRIAGE IN STATUS THEN WRITE(FYLE, '1') +91800 END +91810 END; +91820 (**) +91830 (**) +91840 PROCEDURE SORESET(COV: OBJECTP; VAR FYLE: FYL); +91850 (*OPENED,MOODOK*) +91860 BEGIN WITH COV^ DO +91870 BEGIN +91880 IF RESETPOSS IN POSSIBLES THEN +91890 BEGIN (*+01()(*-52()BOOK^.STATUS := 15B; (*TO FIX A BUG IN PASCAL MK 2*) ()-52*)()+01*) +91900 REWRITE(FYLE) +91910 END; +91920 IF CARRIAGE IN STATUS THEN +91930 WRITE(FYLE, '1'); +91940 STATUS := STATUS-[NOTRESET] +91950 END +91960 END; +91970 (**) +91980 (**) +91990 (*+01() PROCEDURE SOWRSTR(COV,STRNG: OBJECTP; LB,UB: INTEGER; VAR FYLE: FYL); ()+01*) +92000 (*+02() PROCEDURE SOWRSTR(COV,STRNG: OBJECTP; LB,UB: INTEGER; EFET: FETROOMP); ()+02*) +92010 (*+05() PROCEDURE SOWRSTR(COV,STRNG: OBJECTP; LB,UB: INTEGER; EFET: FETROOMP); ()+05*) +92020 (*POSN OF NEXT WIDTH CHARS ENSURED*) +92030 VAR I, WIDTH, J, WORD: INTEGER; +92040 PTR: UNDRESSP; +92050 (*+01() +92060 (*$X0*) +92070 PROCEDURE WRS(VAR FYLE: FYL; ADDR: UNDRESSP; FLDLGTH, STRLGTH: INTEGER); EXTERN; +92080 PROCEDURE WRSN(VAR FYLE: FYL; SHORTSTR: INTEGER; FLDLGTH, STRLGTH: INTEGER); EXTERN; +92090 (*$X4*) +92100 ()+01*) +92110 (*+02() +92120 CPTR: IPOINT; +92130 PROCEDURE WRC(CH :CHAR; FIL :FETROOMP); EXTERN; +92140 PROCEDURE WRS(LEN :INTEGER; CP :IPOINT; FIL :FETROOMP); EXTERN; +92150 ()+02*) +92160 (*+05() +92170 CPTR: CHARPOINT ; +92180 PROCEDURE WRS(P: PCFILE; CP: CHARPOINT; LEN: INTEGER ); EXTERN; +92190 PROCEDURE WRC(P: PCFILE; CH: CHAR); EXTERN; +92200 ()+05*) +92210 BEGIN +92220 (*+01() +92230 WIDTH := 1; +92240 IF LB<0 THEN WRITE(FYLE,CHR(UB)) +92250 ELSE BEGIN +92260 LB := LB-1; +92270 PTR := INCPTR(STRNG, STRINGCONST + LB DIV CHARPERWORD); +92280 WIDTH := UB-LB; +92290 IF LB MOD CHARPERWORD <> 0 THEN +92300 BEGIN +92310 IF WIDTH <= CHARPERWORD - LB MOD CHARPERWORD THEN I := WIDTH ELSE I := CHARPERWORD - LB MOD CHARPERWORD; +92320 WORD := PTR^.FIRSTWORD; +92330 FOR J := 1 TO LB MOD CHARPERWORD DO WORD := WORD * CHARSPACE ; +92340 WRSN(FYLE, WORD, I, I); +92350 PTR := INCPTR(PTR, SZWORD); +92360 END +92370 ELSE I := 0; +92380 WRS(FYLE, PTR, WIDTH-I, WIDTH-I) +92390 END; +92400 ()+01*) +92410 (*+02() +92420 IF LB<0 THEN (*CHAR*) +92430 BEGIN +92440 WIDTH := 1; +92450 WRC(CHR(UB),EFET); +92460 END +92470 ELSE (*STRING*) +92480 BEGIN +92490 WIDTH:=UB-LB+1; +92500 CPTR:= ORD(STRNG) + STRINGCONST + (LB *(SZWORD DIV CHARPERWORD)-1); +92510 WRS(WIDTH,CPTR,EFET); +92520 END; +92530 ()+02*) +92540 (*+05() +92550 IF LB<0 THEN +92560 BEGIN +92570 WIDTH := 1; +92580 WRC(EFET^.XFILE, CHR(UB)) +92590 END +92600 ELSE BEGIN +92610 WIDTH := UB - LB + 1; +92620 CPTR := ASPTR(( ORD( STRNG ) + STRINGCONST )*2 + LB - 1) ; +92630 WRS( EFET^.XFILE , CPTR , WIDTH ) ; +92640 END; +92650 ()+05*) +92660 WITH COV^ DO +92670 BEGIN COFCPOS:=COFCPOS+WIDTH; +92680 IF COFCPOS>CHARBOUND THEN +92690 STATUS:=STATUS+[LINEOVERFLOW]; +92700 END; +92710 END; +92720 (**) +92730 (**) +92740 (*-02() +92750 BEGIN (*OF A68*) +92760 END; (*OF A68*) +92770 ()-02*) +92780 (*+01() +92790 BEGIN (*OF MAIN PROGRAM*) +92800 END (*OF EVERYTHING*). +92810 ()+01*) diff --git a/lang/a68s/liba68s/stbacch.p b/lang/a68s/liba68s/stbacch.p new file mode 100644 index 000000000..794cdb363 --- /dev/null +++ b/lang/a68s/liba68s/stbacch.p @@ -0,0 +1,27 @@ +92900 #include "rundecs.h" +92910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +92920 (**) +92930 (*+01() (*$X6*) ()+01*) +92940 PROCEDURE STBACCH(PCOV: OBJECTP; LFN: LFNTYPE); +92950 BEGIN WITH PCOV^ DO +92960 BEGIN CHARBOUND:=MAXINT; +92970 LINEBOUND:=MAXINT; +92980 PAGEBOUND:=MAXINT; +92990 POSSIBLES:=[GETPOSS,PUTPOSS,RESETPOSS,SETPOSS,BINPOSS,ESTABPOSS]; +93000 STATUS := [OPENED,CHARMOOD]; +93010 (*+01() BOOK^.DISP:=123B; ()+01*) +93020 END +93030 END; +93040 (**) +93050 (**) +93060 (*+01() (*$X4*) ()+01*) +93070 (**) +93080 (**) +93090 (*-02() +93100 BEGIN (*OF A68*) +93110 END; (*OF A68*) +93120 ()-02*) +93130 (*+01() +93140 BEGIN (*OF MAIN PROGRAM*) +93150 END (* OF EVERYTHING *). +93160 ()+01*) diff --git a/lang/a68s/liba68s/stinch.p b/lang/a68s/liba68s/stinch.p new file mode 100644 index 000000000..d2a90f8e5 --- /dev/null +++ b/lang/a68s/liba68s/stinch.p @@ -0,0 +1,61 @@ +93200 #include "rundecs.h" +93210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +93220 (**) +93230 PROCEDURE SETREADMOOD(PCOV:OBJECTP); EXTERN; +93240 (**) +93250 (*+01() (*$X6*) ()+01*) +93260 FUNCTION PROC( PROCEDURE P (*-01() ( COV: OBJECTP ; EFET: FETROOMP ) ()-01*) ): ASPROC ; EXTERN ; +93270 (*-01() +93280 FUNCTION PROC1( +93290 PROCEDURE P( COV: OBJECTP ; CHARS: GETBUFTYPE ; TERM: TERMSET ; I: INTEGER ; EFET: FETROOMP ) +93300 ): ASPROC ; EXTERN ; +93310 ()-01*) +93320 PROCEDURE AOPEN( EFET:FETROOMP; DISP:INTEGER; LFN:LFNTYPE; BUF:IPOINT ); EXTERN; +93330 PROCEDURE SIRDSTR(COV: OBJECTP; CHARS: GETBUFTYPE; TERM (*+01(),TERM1()+01*): TERMSET; I: INTEGER; EFET: FETROOMP); +93340 EXTERN; +93350 PROCEDURE SINEWLINE(COV: OBJECTP; EFET: FETROOMP); EXTERN; +93360 PROCEDURE SINEWPAGE(COV: OBJECTP; EFET: FETROOMP); EXTERN; +93370 PROCEDURE SIRESET(COV: OBJECTP; EFET: FETROOMP); EXTERN; +93380 (**) +93390 (**) +93400 PROCEDURE STINCH(PCOV: OBJECTP; LFN: LFNTYPE); +93410 (*+01() VAR AW66: ^W66; ()+01*) +93420 BEGIN WITH PCOV^ DO +93430 BEGIN CHARBOUND:=MAXINT; +93440 LINEBOUND:=MAXINT; +93450 PAGEBOUND:=MAXINT; +93460 POSSIBLES:=[GETPOSS]; +93470 (*+01() +93480 AW66 := ASPTR(66B); +93490 IF (LFN= 'INPUT:::::') AND (AW66^.JOPR=3) THEN (*INPUT AND ONLINE*) +93500 BEGIN +93510 AOPEN( BOOK, FORREAD + ONLINE, LFN, ORD(BOOK)+BUFFOFFSET ) ; +93520 STATUS := [OPENED,NOTINITIALIZED,NOTRESET,LFE,PAGEOVERFLOW,LINEOVERFLOW,CHARMOOD,LAZY,NOTSET] +93530 END +93540 ELSE +93550 ()+01*) +93560 BEGIN +93570 AOPEN( BOOK, FORREAD, LFN, ORD(BOOK)+BUFFOFFSET ) ; +93580 STATUS := [OPENED,NOTRESET,CHARMOOD,NOTSET(*-01(),LAZY()-01*)] +93590 END; +93600 (*+01() +93610 IF BOOK^.LFN<>'INPUT::' THEN POSSIBLES := POSSIBLES+[RESETPOSS]; +93620 ()+01*) +93630 DOGETS := PROC(*-01()1()-01*)(SIRDSTR); +93640 DONEWLINE := PROC(SINEWLINE); +93650 DONEWPAGE := PROC(SINEWPAGE); +93660 DORESET := PROC(SIRESET); +93670 SETREADMOOD(PCOV) +93680 END +93690 END; +93700 (*+01() (*$X4*) ()+01*) +93710 (**) +93720 (**) +93730 (*-02() +93740 BEGIN (*OF A68*) +93750 END; (*OF A68*) +93760 ()-02*) +93770 (*+01() +93780 BEGIN (*OF MAIN PROGRAM*) +93790 END (* OF EVERYTHING *). +93800 ()+01*) diff --git a/lang/a68s/liba68s/stopen.p b/lang/a68s/liba68s/stopen.p new file mode 100644 index 000000000..dd2486218 --- /dev/null +++ b/lang/a68s/liba68s/stopen.p @@ -0,0 +1,48 @@ +93900 #include "rundecs.h" +93910 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +93920 (**) +93930 FUNCTION CRSTRUCT(TEMPLATE: DPOINT ) : OBJECTP ; EXTERN ; +93940 (*+01() (*$X6*) ()+01*) +93950 PROCEDURE OPENCOVER( +93960 PFET: FETROOMP; VAR PCOV: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP; L: LFNTYPE) ()-01*) +93970 ); EXTERN; +93980 (**) +93990 (**) +94000 PROCEDURE STOPEN( +94010 PFET: FETROOMP; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() (COV: OBJECTP; L: LFNTYPE) ()-01*) +94020 ); +94030 VAR F, PCOV: OBJECTP; +94040 BEGIN +94050 OPENCOVER(PFET, PCOV, LFN, CH); +94060 PCOV^.STATUS := PCOV^.STATUS+[STARTUP]; +94070 F := CRSTRUCT(FILEBLOCK); +94080 WITH F^ DO +94090 BEGIN +94100 FINC; +94110 OSCOPE := 1; +94120 PCOVER := PCOV; +94130 TERM := [] ; (*+01() TERM1 := [] ; ()+01*) +94140 END; +94150 ENEW(RF, REFNSIZE); +94160 WITH RF^ DO +94170 BEGIN +94180 (*-02() FIRSTWORD := SORTSHIFT * ORD(REFN) + INCRF; ()-02*) +94190 (*+02() PCOUNT:=1; SORT:=REFN; ()+02*) +94200 (*+01() SECONDWORD := 0; ()+01*) +94210 ANCESTOR := RF; +94220 OFFSET := STRUCTCONST; +94230 PVALUE := F; +94240 OSCOPE := 3; +94250 END +94260 END; +94270 (*+01() (*$X4*) ()+01*) +94280 (**) +94290 (**) +94300 (*-02() +94310 BEGIN (*OF A68*) +94320 END; (*OF A68*) +94330 ()-02*) +94340 (*+01() +94350 BEGIN (*OF MAIN PROGRAM*) +94360 END (* OF EVERYTHING *). +94370 ()+01*) diff --git a/lang/a68s/liba68s/stoutch.p b/lang/a68s/liba68s/stoutch.p new file mode 100644 index 000000000..5efbb6838 --- /dev/null +++ b/lang/a68s/liba68s/stoutch.p @@ -0,0 +1,76 @@ +98400 #include "rundecs.h" +98410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +98420 (**) +98430 PROCEDURE SETWRITEMOOD(PCOV:OBJECTP); EXTERN; +98440 (*+01() (*$X6*) ()+01*) +98450 PROCEDURE AOPEN( EFET:FETROOMP; DISP:INTEGER; LFN:LFNTYPE; BUF:IPOINT ); EXTERN; +98460 FUNCTION PROC( PROCEDURE P (*-01() ( COV: OBJECTP ; EFET: FETROOMP ) ()-01*) ): ASPROC ; EXTERN ; +98470 (*-01() +98480 FUNCTION PROC2( PROCEDURE P( COV, STRNG: OBJECTP ; LB, UB: INTEGER ; EFET: FETROOMP ) ): ASPROC ; EXTERN ; +98490 ()-01*) +98500 PROCEDURE SONEWLINE(COV: OBJECTP; EFET: FETROOMP); EXTERN; +98510 PROCEDURE SONEWPAGE(COV: OBJECTP; EFET: FETROOMP); EXTERN; +98520 PROCEDURE SORESET(COV: OBJECTP; EFET: FETROOMP); EXTERN; +98530 PROCEDURE SOWRSTR(COV, STRNG: OBJECTP; LB, UB: INTEGER; EFET: FETROOMP); EXTERN; +98540 (**) +98550 (**) +98560 PROCEDURE STOUTCH(PCOV: OBJECTP; LFN: LFNTYPE); +98570 VAR +98580 (*+01() AW66: ^W66 ; ()+01*) +98590 PINT: INTPOINT; +98600 (*+01() +98610 TEMP: PACKED RECORD CASE SEVERAL OF +98620 1: (INT: INTEGER); +98630 2: (LFN: PACKED ARRAY [1..7] OF CHAR; +98640 EFET1: 0..777777B); +98650 0, 3, 4, 5, 6, 7, 8, 9, 10: (); +98660 END; +98670 ()+01*) +98680 (*+05() HEIGHT, WIDTH: INTEGER; ()+05*) +98690 BEGIN WITH PCOV^ DO +98700 BEGIN +98710 CHARBOUND := 120; +98720 LINEBOUND := 60; +98730 PAGEBOUND := 16; +98740 POSSIBLES:=[PUTPOSS,ESTABPOSS]; +98750 AOPEN(BOOK, FORWRITE, LFN, ORD(BOOK)+BUFFOFFSET); +98760 STATUS := [OPENED,NOTRESET,CHARMOOD,NOTSET]; +98770 (*+01() +98780 AW66 := ASPTR(66B); +98790 IF (BOOK^.LFN='OUTPUT:') AND (AW66^.JOPR<>3) (*OUTPUT AND NOT ONLINE*) +98800 OR (BOOK^.LFN='LSTFILE') (*SPECIAL CASE*) THEN +98810 STATUS := STATUS+[CARRIAGE]; +98820 IF (BOOK^.LFN<>'OUTPUT:') AND (BOOK^.LFN<>'LSTFILE') THEN POSSIBLES := POSSIBLES+[RESETPOSS]; +98830 IF (BOOK^.LFN='OUTPUT:') AND (AW66^.JOPR=3) (*OUTPUT AND ONLINE*) THEN +98840 BEGIN +98850 PINT := ASPTR(3); +98860 TEMP.LFN := 'OUTPUT:'; TEMP.EFET1 := ORD(BOOK)+14; +98870 PINT^ := TEMP.INT; (*TO ENSURE THAT OUTPUT GETS FLUSHED*) +98880 CHARBOUND := 79; +98890 END; +98900 ()+01*) +98910 (*+05() +98920 IF WINDOW( BOOK^.XFILE^.FILEDES , HEIGHT , WIDTH ) <> 0 THEN +98930 BEGIN +98940 LINEBOUND := HEIGHT; +98950 CHARBOUND := WIDTH +98960 END ; +98970 ()+05*) +98980 DOPUTS:=PROC(*-01()2()-01*)(SOWRSTR); +98990 DONEWLINE := PROC(SONEWLINE); +99000 DONEWPAGE := PROC(SONEWPAGE); +99010 DORESET := PROC(SORESET); +99020 SETWRITEMOOD(PCOV) +99030 END +99040 END; +99050 (*+01() (*$X4*) ()+01*) +99060 (**) +99070 (**) +99080 (*-02() +99090 BEGIN (*OF A68*) +99100 END; (*OF A68*) +99110 ()-02*) +99120 (*+01() +99130 BEGIN (*OF MAIN PROGRAM*) +99140 END (* OF EVERYTHING *). +99150 ()+01*) diff --git a/lang/a68s/liba68s/strsubtrim.p b/lang/a68s/liba68s/strsubtrim.p new file mode 100644 index 000000000..586368781 --- /dev/null +++ b/lang/a68s/liba68s/strsubtrim.p @@ -0,0 +1,53 @@ +49400 #include "rundecs.h" +49410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +49420 (**) +49430 (**) +49440 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ; +49450 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN; +49460 PROCEDURE ERRORR(N :INTEGER); EXTERN ; +49470 (**) +49480 (**) +49490 FUNCTION STRSUB(OBJECT: OBJECTP; INDEX: BOUNDSRANGE): CHAR; +49500 (*PSTRINGSLICE*) +49510 BEGIN +49520 WITH OBJECT^ DO +49530 BEGIN +49540 IF INDEX<1 THEN ERRORR(RSL1ERROR) +49550 ELSE IF INDEX>STRLENGTH THEN ERRORR(RSL2ERROR) +49560 ELSE STRSUB := CHARVEC[INDEX]; +49570 END; +49580 IF FPTST(OBJECT^) THEN GARBAGE(OBJECT); +49590 END; +49600 (**) +49610 (**) +49620 FUNCTION STRTRIM(INDEX: BOUNDSRANGE; TRTYPE: INTEGER): OBJECTP; +49630 (*PSTRINGSLICE+1*) +49640 VAR OLD, NEW :OBJECTP; +49650 LI, UI: BOUNDSRANGE; +49660 I :INTEGER; +49670 BEGIN +49680 CASE TRTYPE OF +49690 0,8: BEGIN OLD := ASPTR(INDEX); LI := 1; UI := OLD^.STRLENGTH END; +49700 2: BEGIN OLD := ASPTR(GETSTKTOP(SZADDR, 0)); LI := 1; UI := INDEX END; +49710 4: BEGIN OLD := ASPTR(GETSTKTOP(SZADDR, 0)); LI := INDEX; UI := OLD^.STRLENGTH END; +49720 6: BEGIN OLD := ASPTR(GETSTKTOP(SZADDR, SZINT)); LI := GETSTKTOP(SZINT, 0); UI := INDEX END; +49730 END; +49740 IF LI<1 THEN ERRORR(RSL1ERROR) +49750 ELSE IF UI>OLD^.STRLENGTH THEN ERRORR(RSL2ERROR) +49760 ELSE +49770 BEGIN +49780 LI := LI-1; +49790 NEW := CRSTRING(UI-LI); +49800 FOR I := LI+1 TO UI DO +49810 NEW^.CHARVEC[I-LI] := OLD^.CHARVEC[I]; +49820 IF FPTST(OLD^) THEN GARBAGE(OLD); +49830 STRTRIM := NEW; +49840 END; +49850 END; +49860 (**) +49870 (**) +49880 (*-02() BEGIN END ; ()-02*) +49890 (*+01() +49900 BEGIN (*OF MAIN PROGRAM*) +49910 END (*OF EVERYTHING*). +49920 ()+01*) diff --git a/lang/a68s/liba68s/structscope.p b/lang/a68s/liba68s/structscope.p new file mode 100644 index 000000000..fadffeab0 --- /dev/null +++ b/lang/a68s/liba68s/structscope.p @@ -0,0 +1,29 @@ +50000 #include "rundecs.h" +50010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +50020 (**) +50030 (**) +50040 FUNCTION STRUCTSCOPE(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT):DEPTHRANGE; +50050 VAR TEMPOS, STRUCTPOS: INTEGER; +50060 NEWEST: DEPTHRANGE; +50070 PTR: UNDRESSP; +50080 BEGIN +50090 NEWEST := 0; +50100 TEMPOS := 1; +50110 STRUCTPOS := TEMPLATE^[1]; +50120 WHILE STRUCTPOS>=0 DO +50130 BEGIN +50140 PTR := INCPTR(STRUCTPTR, STRUCTPOS); +50150 WITH PTR^.FIRSTPTR^ DO +50160 IF NEWEST0 THEN +52400 WHILE NEXTEL(0, APDESC) DO WITH PDESCVEC[0] DO +52410 BEGIN +52420 I := PP; +52430 WHILE IPDESC2.PSIZE THEN +53370 WHILE NEXTEL(0, PDESC1) DO +53380 WITH PDESC1, PDESCVEC[0] DO +53390 BEGIN +53400 VECPOS := PP; +53410 WHILE VECPOS=CCOUNT THEN +53720 IF CCOUNT<>0 THEN CCOUNT := CCOUNT+1 ELSE (*NA*) +53730 ELSE IF DESTELS^.CCOUNT=0 THEN CCOUNT := 0; +53740 (*CCOUNT=0 TREATED AS INFINITY*) +53750 (*CCOUNT(SOURCELS) = MAX(CCOUNT(SOURCELS), CCOUNT(DESTELS)+1)*) +53760 NEWSOURCE:=COPYDESC(SOURCE,MULT); +53770 FPINC(SOURCELS^); +53780 FPINC(NEWSOURCE^); +53790 IF FPTST(PVALUE^) THEN GARBAGE(PVALUE); +53800 PVALUE:= SOURCELS +53810 END +53820 ELSE +53830 BEGIN +53840 IF FPTWO(PVALUE^) THEN +53850 TESTCC(DESTINATION); +53860 DESTELS := PVALUE; +53870 FORMPDESC(SOURCE, PDESC1); +53880 PCINCRSLICE(SOURCE, PDESC1, +INCRF); +53890 PCINCRMULT(DESTELS, -INCRF); +53900 VECPOS := ELSCONST; +53910 WHILE NEXTEL(0, PDESC1) DO WITH PDESC1, PDESCVEC[0] DO +53920 BEGIN +53930 MOVELEFT(INCPTR(SOURCELS, PP), INCPTR(DESTELS, VECPOS), PSIZE); +53940 VECPOS:= VECPOS+PSIZE +53950 END +53960 END; +53970 IF FPTST(SOURCE^) THEN GARBAGE(SOURCE); +53980 TASSTM := DESTINATION; +53990 END; +54000 (**) +54010 (**) +54020 FUNCTION SCPTTM(DESTINATION, SOURCE: OBJECTP): OBJECTP; +54030 (*PSCOPETT+4*) +54040 BEGIN +54050 WITH SOURCE^ DO +54060 BEGIN +54070 IF OSCOPE=0 THEN OSCOPE := MULTSCOPE(SOURCE); +54080 IF DESTINATION^.OSCOPE>= 1; + while ( p != 0 ) { + n *= n; t *= t; + if ( (p & 1) != 0 ) {r *= n; s *= t; } + p >>= 1; + } + if (pow<0) { + return((a/r)/s); + } else { + return((a*r)*s); + } + } diff --git a/lang/a68s/liba68s/trace.e b/lang/a68s/liba68s/trace.e new file mode 100644 index 000000000..6f2fb58d9 --- /dev/null +++ b/lang/a68s/liba68s/trace.e @@ -0,0 +1,20 @@ +#include "e.h" + + exp $PROCENTR ; calls through to the (lower case) pascal RT system + exp $PROCEXIT + + ; these are calls through to the (lower case) pascal run-time system + + pro $PROCENTR,0 + LFL 0 + cal $procentry + asp SZADDR + ret 0 + end 0 + + pro $PROCEXIT,0 + LFL 0 + cal $procexit + asp SZADDR + ret 0 + end 0 diff --git a/lang/a68s/liba68s/trig.p b/lang/a68s/liba68s/trig.p new file mode 100644 index 000000000..33ac8d84d --- /dev/null +++ b/lang/a68s/liba68s/trig.p @@ -0,0 +1,34 @@ +66300 #include "rundecs.h" +66310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +66320 (**) +66330 (**) +66340 FUNCTION TAN(X: REAL): REAL; +66350 BEGIN TAN := SIN(X)/COS(X) END; +66360 (**) +66370 (**) +66380 FUNCTION ARCCOS(X: REAL): REAL; +66390 BEGIN +66400 IF ABS(X)>0.5 THEN +66410 ARCCOS := ARCTAN(SQRT(1-SQR(X))/X)+ORD(X<0)*(HALFPI.ACTUALPI+HALFPI.ACTUALPI) +66420 ELSE +66430 ARCCOS := HALFPI.ACTUALPI-ARCTAN(X/SQRT(1-SQR(X))); +66440 END; +66450 (**) +66460 (**) +66470 FUNCTION ARCSIN(X: REAL): REAL; +66480 BEGIN +66490 IF ABS(X)<0.5 THEN +66500 ARCSIN := ARCTAN(X/SQRT(1-SQR(X))) +66510 ELSE +66520 ARCSIN := (1-2*ORD(X<0))*HALFPI.ACTUALPI-ARCTAN(SQRT(1-SQR(X))/X); +66530 END; +66540 (**) +66550 (**) +66560 (*-02() +66570 BEGIN (* OF A68 *) +66580 END (* OF A68 *); +66590 ()-02*) +66600 (*+01() +66610 BEGIN (* OF MAIN PROGRAM *) +66620 END (* OF MAIN PROGRAM *). +66630 ()+01*) diff --git a/lang/a68s/liba68s/trim.p b/lang/a68s/liba68s/trim.p new file mode 100644 index 000000000..43acb3f9f --- /dev/null +++ b/lang/a68s/liba68s/trim.p @@ -0,0 +1,181 @@ +55100 #include "rundecs.h" +55110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +55120 (**) +55130 (**) +55140 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ; +55150 PROCEDURE SLCMN(STOWEDVAL: OBJECTP; INDEX, SLICDEX: INTEGER); EXTERN; +55160 (**) +55170 (**) +55180 FUNCTION GETSLN(NEWREFSLN:OBJECTP): OBJECTP; +55190 VAR OLDREF:OBJECTP; +55200 BEGIN +55210 WITH NEWREFSLN^ DO +55220 BEGIN +55230 OLDREF := PVALUE; +55240 ANCESTOR := OLDREF^.ANCESTOR; +55250 WITH ANCESTOR^ DO FINC; +55260 OSCOPE := OLDREF^.OSCOPE; +55270 CCOUNT := 1; +55280 END; +55290 IF FPTST(OLDREF^) THEN GARBAGE(OLDREF); +55300 GETSLN := NEWREFSLN; +55310 END; +55320 (**) +55330 (**) +55340 (*THE FOLLOWING PROCEDURES ARE USUALLY WRITTEN IN ASSEMBLER*) +55350 (**) +55360 (*-01() +55370 PROCEDURE STARTSL(NOROWS, DEPTH: INTEGER); +55380 (*PSTARTSLICE*) +55390 (* SOURDESC, SLICDESC, SOURDEX, SLICDEX, ADJACC *) +55400 BEGIN +55410 SOURDEX:= 0; +55420 SLICDEX:= 0; +55430 SOURDESC := ASPTR(GETSTKTOP(SZADDR, DEPTH)); +55440 ENEW(SLICDESC, REFSLNCONST+NOROWS*SZPDS); +55450 ADJACC := SOURDESC^.LBADJ; +55460 WITH SLICDESC^ DO +55470 BEGIN +55480 (*-02() FIRSTWORD := SORTSHIFT * ORD(REFSLN); ()-02*) +55490 (*+02() PCOUNT:=0; SORT:=REFSLN; ()+02*) +55500 ROWS := NOROWS-1; +55510 MDBLOCK := SOURDESC^.MDBLOCK; +55520 SIZE := SOURDESC^.SIZE +55530 END; +55540 END; +55550 (**) +55560 (**) +55570 PROCEDURE TRIMS (* SOURDESC, SLICDESC, SOURDEX, SLICDEX, ADJACC, +55580 REVISEDLB, SLICEPDS *); +55590 (* ALL PARAMETERS ARE GLOBAL SINCE THERE ARE TOO MANY TO BE PASSED IN *) +55600 (* THE X REGISTERS AND THE PROCEDURES ARE NON RECURSIVE *) +55610 BEGIN +55620 WITH SLICEPDS DO +55630 BEGIN +55640 ADJACC := ADJACC+(REVISEDLB-LI)*DI; +55650 UI:= UI+REVISEDLB-LI; +55660 LI := REVISEDLB; +55670 SLICDESC^.DESCVEC[SLICDEX] := SLICEPDS; +55680 END; +55690 SOURDEX:= SOURDEX+1; +55700 SLICDEX:= SLICDEX+1; +55710 END; +55720 (* *) +55730 PROCEDURE SLICEA(DEPTH: INTEGER) (* SOURDESC, SOURDEX, SLICEPDS*); +55740 (*PTRIM - [ ]*) +55750 BEGIN +55760 SLICEPDS := SOURDESC^.DESCVEC[SOURDEX]; +55770 SLICDESC^.DESCVEC[SLICDEX] := SLICEPDS; +55780 SOURDEX := SOURDEX+1; +55790 SLICDEX := SLICDEX+1; +55800 END; +55810 (* *) +55820 PROCEDURE SLICEB(DEPTH: INTEGER) (*SOURDESC, SLICDESC, SOURDEX, SLICDEX, STACKPOS *); +55830 (*PTRIM+1 - [@N]*) +55840 BEGIN +55850 SLICEPDS := SOURDESC^.DESCVEC[SOURDEX]; +55860 REVISEDLB := GETSTKTOP(SZINT, DEPTH); +55870 TRIMS; +55880 END; +55890 (* *) +55900 PROCEDURE SLICEC(DEPTH: INTEGER) (* ARGUEMENTS AS ABOVE *); +55910 (*PTRIM+2 - [ :U]*) +55920 BEGIN +55930 SLICEPDS := SOURDESC^.DESCVEC[SOURDEX]; +55940 REVISEDLB := 1; +55950 IF GETSTKTOP(SZINT, DEPTH)>SLICEPDS.UI THEN SLCMN(SOURDESC, GETSTKTOP(SZINT, DEPTH), SOURDEX); +55960 SLICEPDS.UI := GETSTKTOP(SZINT, DEPTH); +55970 TRIMS; +55980 END; +55990 (* *) +56000 PROCEDURE SLICED(DEPTH: INTEGER) (* AS ABOVE *); +56010 (*PTRIM+3 - [:U@N]*) +56020 BEGIN +56030 SLICEPDS := SOURDESC^.DESCVEC[SOURDEX]; +56040 REVISEDLB := GETSTKTOP(SZINT, DEPTH); +56050 IF GETSTKTOP(SZINT, DEPTH+SZINT)>SLICEPDS.UI THEN SLCMN(SOURDESC, GETSTKTOP(SZINT, SZINT), SOURDEX); +56060 SLICEPDS.UI := GETSTKTOP(SZINT, DEPTH+SZINT); +56070 TRIMS; +56080 END; +56090 (* *) +56100 PROCEDURE SLICEE(DEPTH: INTEGER) (* AS ABOVE *); +56110 (*PTRIM+4 - [L: ]*) +56120 BEGIN +56130 SLICEPDS := SOURDESC^.DESCVEC[SOURDEX]; +56140 REVISEDLB:= 1; +56150 IF GETSTKTOP(SZINT, DEPTH)SLICEPDS.UI THEN SLCMN(SOURDESC, GETSTKTOP(SZINT, DEPTH), SOURDEX); +56360 SLICEPDS.UI := GETSTKTOP(SZINT, DEPTH); +56370 IF GETSTKTOP(SZINT, DEPTH+SZINT)SLICEPDS.UI THEN SLCMN(SOURDESC, GETSTKTOP(SZINT, DEPTH+SZINT), SOURDEX); +56480 SLICEPDS.UI := GETSTKTOP(SZINT, DEPTH+SZINT); +56490 IF GETSTKTOP(SZINT, DEPTH+2*SZINT)UI) THEN +56690 SLCMN (SOURDESC , GETSTKTOP (SZINT , DEPTH) , SOURDEX ) ; +56700 ADJACC := ADJACC-GETSTKTOP(SZINT, DEPTH)*DI; +56710 END; +56720 SOURDEX:= SOURDEX+1; +56730 END; +56740 (**) +56750 (**) +56760 FUNCTION ENDSL(PRIMARY: OBJECTP) (* SLICDESC, ADJACC +) : OBJECTP; +56770 (*PENDSLICE*) +56780 BEGIN +56790 SLICDESC^.LBADJ := ADJACC; +56800 SLICDESC^.PVALUE := PRIMARY; +56810 ENDSL := SLICDESC +56820 END; +56830 ()-01*) +56840 (**) +56850 (**) +56860 (*-02() BEGIN END ; ()-02*) +56870 (*+01() +56880 BEGIN (*OF MAIN PROGRAM*) +56890 END (*OF EVERYTHING*). +56900 ()+01*) diff --git a/lang/a68s/liba68s/uplwb.p b/lang/a68s/liba68s/uplwb.p new file mode 100644 index 000000000..48379a302 --- /dev/null +++ b/lang/a68s/liba68s/uplwb.p @@ -0,0 +1,36 @@ +62800 #include "rundecs.h" +62810 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +62820 (**) +62830 (**) +62840 PROCEDURE ERRORR(N :INTEGER); EXTERN ; +62850 (**) +62860 (**) +62870 FUNCTION LWB(D: INTEGER; MULT: OBJECTP): INTEGER; +62880 (*PLWB*) +62890 BEGIN +62900 WITH MULT^ DO +62910 BEGIN +62920 D := D-1; +62930 IF (D<0) OR (D>ROWS) THEN ERRORR(RLWUPB); +62940 LWB := DESCVEC[ROWS-D].LI; +62950 END +62960 END; +62970 (**) +62980 (**) +62990 FUNCTION UPB(D: INTEGER; MULT: OBJECTP): INTEGER; +63000 (*PUPB*) +63010 BEGIN +63020 WITH MULT^ DO +63030 BEGIN +63040 D := D-1; +63050 IF (D<0) OR (D>ROWS) THEN ERRORR(RLWUPB); +63060 UPB := DESCVEC[ROWS-D].UI; +63070 END +63080 END; +63090 (**) +63100 (**) +63110 (*-02() BEGIN END ; ()-02*) +63120 (*+01() +63130 BEGIN (*OF MAIN PROGRAM*) +63140 END (*OF EVERYTHING*). +63150 ()+01*) diff --git a/lang/a68s/liba68s/uplwbm.p b/lang/a68s/liba68s/uplwbm.p new file mode 100644 index 000000000..694698c28 --- /dev/null +++ b/lang/a68s/liba68s/uplwbm.p @@ -0,0 +1,25 @@ +63200 #include "rundecs.h" +63210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +63220 (**) +63230 (**) +63240 FUNCTION LWBM(MULT: OBJECTP): INTEGER; +63250 (*PLWBM*) +63260 BEGIN +63270 WITH MULT^ DO +63280 LWBM := DESCVEC[ROWS].LI; +63290 END; +63300 (**) +63310 (**) +63320 FUNCTION UPBM(MULT: OBJECTP): INTEGER; +63330 (*PUPBM*) +63340 BEGIN +63350 WITH MULT^ DO +63360 UPBM := DESCVEC[ROWS].UI; +63370 END; +63380 (**) +63390 (**) +63400 (*-02() BEGIN END ; ()-02*) +63410 (*+01() +63420 BEGIN (*OF MAIN PROGRAM*) +63430 END (*OF EVERYTHING*). +63440 ()+01*) diff --git a/lang/a68s/liba68s/uplwbmstr.p b/lang/a68s/liba68s/uplwbmstr.p new file mode 100644 index 000000000..4f28c25da --- /dev/null +++ b/lang/a68s/liba68s/uplwbmstr.p @@ -0,0 +1,28 @@ +63500 #include "rundecs.h" +63510 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +63520 (**) +63530 (**) +63540 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ; +63550 (**) +63560 (**) +63570 FUNCTION UPBMSTR(POINT: OBJECTP): INTEGER; +63580 (*PUPBMSTR*) +63590 BEGIN +63600 UPBMSTR := POINT^.STRLENGTH; +63610 IF FPTST(POINT^) THEN GARBAGE(POINT) +63620 END; +63630 (**) +63640 (**) +63650 FUNCTION LWBMSTR(POINT: OBJECTP): INTEGER; +63660 (*PLWBMSTR*) +63670 BEGIN +63680 IF FPTST(POINT^) THEN GARBAGE(POINT); +63690 LWBMSTR := 1; +63700 END; +63710 (**) +63720 (**) +63730 (*-02() BEGIN END ; ()-02*) +63740 (*+01() +63750 BEGIN (*OF MAIN PROGRAM*) +63760 END (*OF EVERYTHING*). +63770 ()+01*) diff --git a/lang/a68s/liba68s/whole.p b/lang/a68s/liba68s/whole.p new file mode 100644 index 000000000..1d8cd053e --- /dev/null +++ b/lang/a68s/liba68s/whole.p @@ -0,0 +1,34 @@ +99200 #include "rundecs.h" +99210 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +99220 (**) +99230 (**) +99240 FUNCTION SUBFIXED(SIGN, BEFORE, POINT, AFTER : INTEGER; VAR EXP: INTEGER; EXPNEEDED: BOOLEAN; +99250 X: REALTEGER; R: BOOLEAN; VAR S: OBJECTP; START: INTEGER): BOOLEAN; EXTERN; +99260 PROCEDURE ERRORFILL(VAR S: OBJECTP; LENGTH: INTEGER); EXTERN; +99270 (**) +99280 (**) +99290 FUNCTION WHOLE(XMODE: INTEGER; VAL: REALTEGER; WIDTH: INTEGER): OBJECTP; +99300 VAR +99310 S: OBJECTP; +99320 SIGN, E: INTEGER; +99330 BEGIN +99340 SIGN := ORD((WIDTH>0) OR (VAL.INT<0)); +99350 S := NIL; +99360 IF NOT SUBFIXED(SIGN, +99370 ABS(WIDTH)-SIGN-ORD(WIDTH=0), (*-VE FOR WIDTH=0*) +99380 0, 0, E, FALSE, +99390 VAL, XMODE=2, +99400 S, 1) THEN +99410 ERRORFILL(S, ABS(WIDTH)+ORD(WIDTH=0)); +99420 WHOLE := S; +99430 END; +99440 (**) +99450 (**) +99460 (*-02() +99470 BEGIN (*OF A68*) +99480 END; (*OF A68*) +99490 ()-02*) +99500 (*+01() +99510 BEGIN (*OF MAIN PROGRAM*) +99520 END (* OF EVERYTHING *). +99530 ()+01*) diff --git a/lang/a68s/liba68s/widchar.p b/lang/a68s/liba68s/widchar.p new file mode 100644 index 000000000..c73ba1956 --- /dev/null +++ b/lang/a68s/liba68s/widchar.p @@ -0,0 +1,22 @@ +57000 #include "rundecs.h" +57010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +57020 (**) +57030 (**) +57040 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN; +57050 (**) +57060 (**) +57070 FUNCTION WIDCHAR(CH: CHAR): OBJECTP; +57080 (*PWIDEN+4*) +57090 VAR POINT :OBJECTP; +57100 BEGIN +57110 POINT := CRSTRING(1); +57120 POINT^.CHARVEC[1] := CH; +57130 WIDCHAR := POINT; +57140 END; +57150 (**) +57160 (**) +57170 (*-02() BEGIN END ; ()-02*) +57180 (*+01() +57190 BEGIN (*OF MAIN PROGRAM*) +57200 END (*OF EVERYTHING*). +57210 ()+01*) diff --git a/lang/a68s/liba68s/widen.p b/lang/a68s/liba68s/widen.p new file mode 100644 index 000000000..051ae4ca4 --- /dev/null +++ b/lang/a68s/liba68s/widen.p @@ -0,0 +1,90 @@ +57300 #include "rundecs.h" +57310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) +57320 (**) +57330 (**) +57340 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ; +57350 (**) +57360 (**) +57370 FUNCTION WIDENM(COUNT: INTEGER): OBJECTP; +57380 VAR NEWELS, NEWMULT: OBJECTP; +57390 BEGIN +57400 ENEW(NEWMULT, MULTCONST+SZPDS); +57410 WITH NEWMULT^ DO +57420 BEGIN +57430 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*) +57440 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*) +57450 (*+01() SECONDWORD := 0; ()+01*) +57460 SIZE := 1; +57470 WITH DESCVEC[0] DO +57480 BEGIN LI := 1; UI := COUNT; DI := SZINT END; +57490 ROWS := 0; LBADJ := SZINT-ELSCONST; PCOUNT := 1; +57500 MDBLOCK := ASPTR(SZINT); +57510 ENEW(NEWELS, ELSCONST+COUNT*SZINT); +57520 WITH NEWELS^ DO +57530 BEGIN +57540 (*-02() FIRSTWORD := SORTSHIFT * ORD(IELS); ()-02*) +57550 (*+02() PCOUNT:=0; SORT:=IELS; ()+02*) +57560 OSCOPE := 0; +57570 IHEAD := NIL; +57580 DBLOCK := ASPTR(SZINT); D0 := COUNT*SZINT; CCOUNT := 1; PCOUNT := 1; +57590 END; +57600 PVALUE := NEWELS; IHEAD := NIL; FPTR := NIL; BPTR := NIL +57610 END; +57620 WIDENM := NEWMULT; +57630 END; +57640 (**) +57650 (**) +57660 FUNCTION WIDBITS(BITS: INTEGER): OBJECTP; +57670 (*PWIDEN+5*) +57680 VAR NEWMULT: OBJECTP; +57690 PTR: UNDRESSP; +57700 BEGIN +57710 NEWMULT := WIDENM(BITSWIDTH); +57720 WITH NEWMULT^ DO +57730 BEGIN +57740 PTR := INCPTR(PVALUE, ELSCONST); +57750 WHILE ORD(PTR)