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