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*)